Mercurial > emacs
changeset 38299:b97c155e6976
properly mark Attic files as deleted
| author | Ken Raeburn <raeburn@raeburn.org> |
|---|---|
| date | Fri, 06 Jul 2001 08:41:36 +0000 |
| parents | 29603bd8ddb0 |
| children | 4a7286bcdc6d |
| files | =PROBLEMS etc/=MACHINES etc/=TO-DO etc/=news.texi etc/termcap.dat lib-src/=aixcc.lex lib-src/=etags-vmslib.c lib-src/=rcs2log lib-src/=timer.c lib-src/=wakeup.c lib-src/env.c lib-src/make-path.c lisp/=ada.el lisp/=batmode.el lisp/=bytecpat.el lisp/=cl.el lisp/=cmulisp.el lisp/=custom.el lisp/=diary-ins.el lisp/=diary-lib.el lisp/=ftp.el lisp/=gnus-uu.el lisp/=gnus.el lisp/=gnusmail.el lisp/=gnusmisc.el lisp/=gnuspost.el lisp/=gosmacs.el lisp/=grow-vers.el lisp/=inc-vers.el lisp/=isearch-old.el lisp/=iso8859-1.el lisp/=libc.el lisp/=man.el lisp/=medit.el lisp/=mh-e.el lisp/=mhspool.el lisp/=mim-mode.el lisp/=mim-syntax.el lisp/=netunam.el lisp/=nnspool.el lisp/=nntp.el lisp/=old-shell.el lisp/=sc-alist.el lisp/=sc-elec.el lisp/=sc.el lisp/=setaddr.el lisp/=speedbspec.el lisp/=sun-keys.el lisp/=superyank.el lisp/=term-nasty.el lisp/=timer.el lisp/=tpu-doc.el lisp/=vmsx.el lisp/=word-help.el lisp/gnus/=md5.el lisp/gnus/=nnheaderxm.el lispref/=buffer-local.texi nt/config.w95 nt/debug.bat nt/emacs.bat nt/install src/=Makefile.in src/=XTests.c src/=XTests.h src/=convexos.h src/=environ.c src/=mach2.h src/=old-ralloc.c src/=sol2-2.h src/=unexelf1.c src/=unexsgi.c src/=x11term.h src/=xscrollbar.h src/=xselect.c.old src/m/=dos386.h tparam.c |
| diffstat | 76 files changed, 0 insertions(+), 48865 deletions(-) [+] |
line wrap: on
line diff
--- a/=PROBLEMS Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,744 +0,0 @@ -This file describes various problems that have been encountered -in compiling, installing and running GNU Emacs. - -* `Pid xxx killed due to text modification or page I/O error' - -On HP/UX, you can get that error when the Emacs executable is on an NFS -file system. HP/UX responds this way if it tries to swap in a page and -does not get a response from the server within a timeout whose default -value is just ten seconds. - -If this happens to you, extend the timeout period. - -* `expand-file-name' fails to work on any but the machine you dumped Emacs on. - -On Ultrix, if you use any of the functions which look up information -in the passwd database before dumping Emacs (say, by using -expand-file-name in site-init.el), then those functions will not work -in the dumped Emacs on any host but the one Emacs was dumped on. - -The solution? Don't use expand-file-name in site-init.el, or in -anything it loads. Yuck - some solution. - -I'm not sure why this happens; if you can find out exactly what is -going on, and perhaps find a fix or a workaround, please let us know. -Perhaps the YP functions cache some information, the cache is included -in the dumped Emacs, and is then inaccurate on any other host. - -* On some variants of SVR4, Emacs does not work at all with X. - -Try defining BROKEN_FIONREAD in your config.h file. If this solves -the problem, please send a bug report to tell us this is needed; be -sure to say exactly what type of machine and system you are using. - -* Linking says that the functions insque and remque are undefined. - -Change oldXMenu/Makefile by adding insque.o to the variable OBJS. - -* Emacs fails to understand most Internet host names, even though -the names work properly with other programs on the same system. - -This typically happens on Suns and other systems that use shared -libraries. The cause is that the site has installed a version of the -shared library which uses a name server--but has not installed a -similar version of the unshared library which Emacs uses. - -The result is that most programs, using the shared library, work with -the nameserver, but Emacs does not. - -The fix is to install an unshared library that corresponds to what you -installed in the shared library, and then relink Emacs. - -* On a Sun running SunOS 4.1.1, you get this error message from GNU ld: - - /lib/libc.a(_Q_sub.o): Undefined symbol __Q_get_rp_rd referenced from text segment - -The problem is in the Sun shared C library, not in GNU ld. - -The solution is to install Patch-ID# 100267-03 from Sun. - -* Self documentation messages are garbled. - -This means that the file `etc/DOC-...' doesn't properly correspond -with the Emacs executable. Redumping Emacs and then installing the -corresponding pair of files should fix the problem. - -* Trouble using ptys on AIX. - -People often install the pty devices on AIX incorrectly. -Use `smit pty' to reinstall them properly. - -* Shell mode on HP/UX gives the message, "`tty`: Ambiguous". - -christos@theory.tn.cornell.edu says: - -The problem is that in your .cshrc you have something that tries to -execute `tty`. If you are not running the shell on a real tty then -tty will print "not a tty". Csh expects one word in some places, -but tty is giving it back 3. - -The solution is to add a pair of quotes around `tty` to make it a single -word: - -if (`tty` == "/dev/console") - -should be changed to: - -if ("`tty`" == "/dev/console") - -Even better, move things that set up terminal sections out of .cshrc -and into .login. - -* Using X Windows, control-shift-leftbutton makes Emacs hang. - -Use the shell command `xset bc' to make the old X Menu package work. - -* Emacs running under X Windows does not handle mouse clicks. -* `emacs -geometry 80x20' finds a file named `80x20'. - -One cause of such problems is having (setq term-file-prefix nil) in -your .emacs file. Another cause is a bad value of EMACSLOADPATH in -the environment. - -* Emacs starts in a directory other than the one that is current in the shell. - -If the PWD environment variable exists, Emacs uses this variable as -the initial working directory. - -Some shells automatically update this variable, while other shells fail -to do so. If you use two such shells in combination, the variable can -end up wrong. This confuses Emacs. - -The solution is to put something in the start-up file for the shell -that does not update PWD, to get rid of that environment variable. -For example, in csh, use `unsetenv PWD'. - -* Emacs gets error message from linker on Sun. - -If the error message says that a symbol such as `f68881_used' or -`ffpa_used' or `start_float' is undefined, this probably indicates -that you have compiled some libraries, such as the X libraries, -with a floating point option other than the default. - -It's not terribly hard to make this work with small changes in -crt0.c together with linking with Fcrt1.o, Wcrt1.o or Mcrt1.o. -However, the easiest approach is to build Xlib with the default -floating point option: -fsoft. - -* Emacs fails to get default settings from X Windows server. - -The X library in X11R4 has a bug; it interchanges the 2nd and 3rd -arguments to XGetDefaults. Define the macro XBACKWARDS in config.h to -tell Emacs to compensate for this. - -I don't believe there is any way Emacs can determine for itself -whether this problem is present on a given system. - -* Keyboard input gets confused after a beep when using a DECserver - as a concentrator. - -This problem seems to be a matter of configuring the DECserver to use -7 bit characters rather than 8 bit characters. - -* M-x shell persistently reports "Process shell exited abnormally with code 1". - -This happened on Suns as a result of what is said to be a bug in Sunos -version 4.0.x. The only fix was to reboot the machine. - -* Programs running under terminal emulator do not recognize `emacs' - terminal type. - -The cause of this is a shell startup file that sets the TERMCAP -environment variable. The terminal emulator uses that variable to -provide the information on the special terminal type that Emacs -emulates. - -Rewrite your shell startup file so that it does not change TERMCAP -in such a case. You could use the following conditional which sets -it only if it is undefined. - - if ( ! ${?TERMCAP} ) setenv TERMCAP ~/my-termcap-file - -Or you could set TERMCAP only when you set TERM--which should not -happen in a non-login shell. - -* X Windows doesn't work if DISPLAY uses a hostname. - -People have reported kernel bugs in certain systems that cause Emacs -not to work with X Windows if DISPLAY is set using a host name. But -the problem does not occur if DISPLAY is set to `unix:0.0'. I think -the bug has to do with SIGIO or FIONREAD. - -You may be able to compensate for the bug by doing (set-input-mode nil nil). -However, that has the disadvantage of turning off interrupts, so that -you are unable to quit out of a Lisp program by typing C-g. - -The easy way to do this is to put - - (setq x-sigio-bug t) - -in your site-init.el file. - -* Problem with remote X server on Suns. - -On a Sun, running Emacs on one machine with the X server on another -may not work if you have used the unshared system libraries. This -is because the unshared libraries fail to use YP for host name lookup. -As a result, the host name you specify may not be recognized. - -* Watch out for .emacs files and EMACSLOADPATH environment vars - -These control the actions of Emacs. -~/.emacs is your Emacs init file. -EMACSLOADPATH overrides which directories the function -"load" will search. - -If you observe strange problems, check for these and get rid -of them, then try again. - -* Shell mode ignores interrupts on Apollo Domain - -You may find that M-x shell prints the following message: - - Warning: no access to tty; thus no job control in this shell... - -This can happen if there are not enough ptys on your system. -Here is how to make more of them. - - % cd /dev - % ls pty* - # shows how many pty's you have. I had 8, named pty0 to pty7) - % /etc/crpty 8 - # creates eight new pty's - -* Fatal signal in the command temacs -l loadup inc dump - -This command is the final stage of building Emacs. It is run by the -Makefile in the src subdirectory, or by build.com on VMS. - -It has been known to get fatal errors due to insufficient swapping -space available on the machine. - -On 68000's, it has also happened because of bugs in the -subroutine `alloca'. Verify that `alloca' works right, even -for large blocks (many pages). - -* test-distrib says that the distribution has been clobbered -* or, temacs prints "Command key out of range 0-127" -* or, temacs runs and dumps xemacs, but xemacs totally fails to work. -* or, temacs gets errors dumping xemacs - -This can be because the .elc files have been garbled. Do not be -fooled by the fact that most of a .elc file is text: these are -binary files and can contain all 256 byte values. - -In particular `shar' cannot be used for transmitting GNU Emacs. -It typically truncates "lines". What appear to be "lines" in -a binary file can of course be of any length. Even once `shar' -itself is made to work correctly, `sh' discards null characters -when unpacking the shell archive. - -I have also seen character \177 changed into \377. I do not know -what transfer means caused this problem. Various network -file transfer programs are suspected of clobbering the high bit. - -If you have a copy of Emacs that has been damaged in its -nonprinting characters, you can fix them: - - 1) Record the names of all the .elc files. - 2) Delete all the .elc files. - 3) Recompile alloc.c with a value of PURESIZE twice as large. - You might as well save the old alloc.o. - 4) Remake xemacs. It should work now. - 5) Running xemacs, do Meta-x byte-compile-file repeatedly - to recreate all the .elc files that used to exist. - You may need to increase the value of the variable - max-lisp-eval-depth to succeed in running the compiler interpreted - on certain .el files. 400 was sufficient as of last report. - 6) Reinstall the old alloc.o (undoing changes to alloc.c if any) - and remake temacs. - 7) Remake xemacs. It should work now, with valid .elc files. - -* temacs prints "Pure Lisp storage exhausted" - -This means that the Lisp code loaded from the .elc and .el -files during temacs -l loadup inc dump took up more -space than was allocated. - -This could be caused by - 1) adding code to the preloaded Lisp files - 2) adding more preloaded files in loadup.el - 3) having a site-init.el or site-load.el which loads files. - Note that ANY site-init.el or site-load.el is nonstandard; - if you have received Emacs from some other site - and it contains a site-init.el or site-load.el file, consider - deleting that file. - 4) getting the wrong .el or .elc files - (not from the directory you expected). - 5) deleting some .elc files that are supposed to exist. - This would cause the source files (.el files) to be - loaded instead. They take up more room, so you lose. - 6) a bug in the Emacs distribution which underestimates - the space required. - -If the need for more space is legitimate, change the definition -of PURESIZE in puresize.h. - -But in some of the cases listed above, this problem is a consequence -of something else that is wrong. Be sure to check and fix the real -problem. - -* Changes made to .el files do not take effect. - -You may have forgotten to recompile them into .elc files. -Then the old .elc files will be loaded, and your changes -will not be seen. To fix this, do M-x byte-recompile-directory -and specify the directory that contains the Lisp files. - -Emacs should print a warning when loading a .elc file which is older -than the corresponding .el file. - -* The dumped Emacs (xemacs) crashes when run, trying to write pure data. - -Two causes have been seen for such problems. - -1) On a system where getpagesize is not a system call, it is defined -as a macro. If the definition (in both unexec.c and malloc.c) is wrong, -it can cause problems like this. You might be able to find the correct -value in the man page for a.out (5). - -2) Some systems allocate variables declared static among the -initialized variables. Emacs makes all initialized variables in most -of its files pure after dumping, but the variables declared static and -not initialized are not supposed to be pure. On these systems you -may need to add "#define static" to the m- or the s- file. - -* Compilation errors on VMS. - -You will get warnings when compiling on VMS because there are -variable names longer than 32 (or whatever it is) characters. -This is not an error. Ignore it. - -VAX C does not support #if defined(foo). Uses of this construct -were removed, but some may have crept back in. They must be rewritten. - -There is a bug in the C compiler which fails to sign extend characters -in conditional expressions. The bug is: - char c = -1, d = 1; - int i; - - i = d ? c : d; -The result is i == 255; the fix is to typecast the char in the -conditional expression as an (int). Known occurrences of such -constructs in Emacs have been fixed. - -* rmail gets error getting new mail - -rmail gets new mail from /usr/spool/mail/$USER using a program -called `movemail'. This program interlocks with /bin/mail using -the protocol defined by /bin/mail. - -There are two different protocols in general use. One of them uses -the `flock' system call. The other involves creating a lock file; -`movemail' must be able to write in /usr/spool/mail in order to do -this. You control which one is used by defining, or not defining, -the macro MAIL_USE_FLOCK in config.h or the m- or s- file it includes. -IF YOU DON'T USE THE FORM OF INTERLOCKING THAT IS NORMAL ON YOUR -SYSTEM, YOU CAN LOSE MAIL! - -If your system uses the lock file protocol, and fascist restrictions -prevent ordinary users from writing the lock files in /usr/spool/mail, -you may need to make `movemail' setgid to a suitable group such as -`mail'. You can use these commands (as root): - - chgrp mail movemail - chmod 2755 movemail - -* Emacs won't work with X-windows if the value of DISPLAY is HOSTNAME:0. -* GNUs can't make contact with the specified host for nntp. - -Some people have found that Emacs was unable to connect to the local -host by name, as in DISPLAY=prep:0 if you are running on prep, but -could handle DISPLAY=unix:0. Here is what tale@rpi.edu said: - - Seems as - though gethostbyname was bombing somewhere along the way. Well, we - had just upgrade from SunOS 3.5 (which X11 was built under) to SunOS - 4.0.1. Any new X applications which tried to be built with the pre - OS-upgrade libraries had the same problems which Emacs was having. - Missing /etc/resolv.conf for a little while (when one of the libraries - was built?) also might have had a hand in it. - - The result of all of this (with some speculation) was that we rebuilt - X and then rebuilt Emacs with the new libraries. Works as it should - now. Hoorah. - -If you have already installed the name resolver in the file libresolv.a, -then you need to compile Emacs to use that library. The easiest way to -do this is to add to config.h a definition of LIBS_SYSTEM, LIBS_MACHINE -or LIB_STANDARD which uses -lresolv. Watch out! If you redefine a macro -that is already in use in your configuration to supply some other libraries, -be careful not to lose the others. - -Thus, you could start by adding this to config.h: - -#define LIBS_SYSTEM -lresolv - -Then if this gives you an error for redefining a macro, and you see that -the s- file defines LIBS_SYSTEM as -lfoo -lbar, you could change config.h -again to say this: - -#define LIBS_SYSTEM -lresolv -lfoo -lbar - -* Emacs spontaneously displays "I-search: " at the bottom of the screen. - -This means that Control-S/Control-Q "flow control" is being used. -C-s/C-q flow control is bad for Emacs editors because it takes away -C-s and C-q as user commands. Since editors do not output long streams -of text without user commands, there is no need for a user-issuable -"stop output" command in an editor; therefore, a properly designed -flow control mechanism would transmit all possible input characters -without interference. Designing such a mechanism is easy, for a person -with at least half a brain. - -There are three possible reasons why flow control could be taking place: - - 1) Terminal has not been told to disable flow control - 2) Insufficient padding for the terminal in use - 3) Some sort of terminal concentrator or line switch is responsible - -First of all, many terminals have a set-up mode which controls -whether they generate flow control characters. This must be -set to "no flow control" in order for Emacs to work. Sometimes -there is an escape sequence that the computer can send to turn -flow control off and on. If so, perhaps the termcap `ti' string -should turn flow control off, and the `te' string should turn it on. - -Once the terminal has been told "no flow control", you may find it -needs more padding. The amount of padding Emacs sends is controlled -by the termcap entry for the terminal in use, and by the output baud -rate as known by the kernel. The shell command `stty' will print -your output baud rate; `stty' with suitable arguments will set it if -it is wrong. Setting to a higher speed causes increased padding. If -the results are wrong for the correct speed, there is probably a -problem in the termcap entry. You must speak to a local Unix wizard -to fix this. Perhaps you are just using the wrong terminal type. - -For terminals that lack a "no flow control" mode, sometimes just -giving lots of padding will prevent actual generation of flow control -codes. You might as well try it. - -If you are really unlucky, your terminal is connected to the computer -through a concentrator which sends flow control to the computer, or it -insists on sending flow control itself no matter how much padding you -give it. You are screwed! You should replace the terminal or -concentrator with a properly designed one. In the mean time, -some drastic measures can make Emacs semi-work. - -One drastic measure to ignore C-s and C-q, while sending enough -padding that the terminal will not really lose any output. To make -such an adjustment, you need only invoke the function -enable-flow-control-on with a list of terminal types in your own -.emacs file. As arguments, give it the names of one or more terminal -types you use which require flow control adjustments. -Here's an example: - -(enable-flow-control-on "vt200" "vt300" "vt101" "vt131") - -An even more drastic measure is to make Emacs use flow control. -To do this, evaluate the Lisp expression (set-input-mode nil t). -Emacs will then interpret C-s and C-q as flow control commands. (More -precisely, it will allow the kernel to do so as it usually does.) You -will lose the ability to use them for Emacs commands. Also, as a -consequence of using CBREAK mode, the terminal's Meta-key, if any, -will not work, and C-g will be liable to cause a loss of output which -will produce garbage on the screen. (These problems apply to 4.2BSD; -they may not happen in 4.3 or VMS, and I don't know what would happen -in sysV.) You can use keyboard-translate-table, as shown above, -to map two other input characters (such as C-^ and C-\) into C-s and -C-q, so that you can still search and quote. - -I have no intention of ever redesigning the Emacs command set for -the assumption that terminals use C-s/C-q flow control. This -flow control technique is a bad design, and terminals that need -it are bad merchandise and should not be purchased. If you can -get some use out of GNU Emacs on inferior terminals, I am glad, -but I will not make Emacs worse for properly designed systems -for the sake of inferior systems. - -* Control-S and Control-Q commands are ignored completely. - -For some reason, your system is using brain-damaged C-s/C-q flow -control despite Emacs's attempts to turn it off. Perhaps your -terminal is connected to the computer through a concentrator -that wants to use flow control. - -You should first try to tell the concentrator not to use flow control. -If you succeed in this, try making the terminal work without -flow control, as described in the preceding section. - -If that line of approach is not successful, map some other characters -into C-s and C-q using keyboard-translate-table. The example above -shows how to do this with C-^ and C-\. - -* Control-S and Control-Q commands are ignored completely on a net connection. - -Some versions of rlogin (and possibly telnet) do not pass flow -control characters to the remote system to which they connect. -On such systems, emacs on the remote system cannot disable flow -control on the local system. - -One way to cure this is to disable flow control on the local host -(the one running rlogin, not the one running rlogind) using the -stty command, before starting the rlogin process. On many systems, -"stty start u stop u" will do this. - -Some versions of tcsh will prevent even this from working. One way -around this is to start another shell before starting rlogin, and -issue the stty command to disable flow control from that shell. - -* Screen is updated wrong, but only on one kind of terminal. - -This could mean that the termcap entry you are using for that -terminal is wrong, or it could mean that Emacs has a bug handing -the combination of features specified for that terminal. - -The first step in tracking this down is to record what characters -Emacs is sending to the terminal. Execute the Lisp expression -(open-termscript "./emacs-script") to make Emacs write all -terminal output into the file ~/emacs-script as well; then do -what makes the screen update wrong, and look at the file -and decode the characters using the manual for the terminal. -There are several possibilities: - -1) The characters sent are correct, according to the terminal manual. - -In this case, there is no obvious bug in Emacs, and most likely you -need more padding, or possibly the terminal manual is wrong. - -2) The characters sent are incorrect, due to an obscure aspect - of the terminal behavior not described in an obvious way - by termcap. - -This case is hard. It will be necessary to think of a way for -Emacs to distinguish between terminals with this kind of behavior -and other terminals that behave subtly differently but are -classified the same by termcap; or else find an algorithm for -Emacs to use that avoids the difference. Such changes must be -tested on many kinds of terminals. - -3) The termcap entry is wrong. - -See the file etc/TERMS for information on changes -that are known to be needed in commonly used termcap entries -for certain terminals. - -4) The characters sent are incorrect, and clearly cannot be - right for any terminal with the termcap entry you were using. - -This is unambiguously an Emacs bug, and can probably be fixed -in termcap.c, tparam.c, term.c, scroll.c, cm.c or dispnew.c. - -* Output from Control-V is slow. - -On many bit-map terminals, scrolling operations are fairly slow. -Often the termcap entry for the type of terminal in use fails -to inform Emacs of this. The two lines at the bottom of the screen -before a Control-V command are supposed to appear at the top after -the Control-V command. If Emacs thinks scrolling the lines is fast, -it will scroll them to the top of the screen. - -If scrolling is slow but Emacs thinks it is fast, the usual reason is -that the termcap entry for the terminal you are using does not -specify any padding time for the `al' and `dl' strings. Emacs -concludes that these operations take only as much time as it takes to -send the commands at whatever line speed you are using. You must -fix the termcap entry to specify, for the `al' and `dl', as much -time as the operations really take. - -Currently Emacs thinks in terms of serial lines which send characters -at a fixed rate, so that any operation which takes time for the -terminal to execute must also be padded. With bit-map terminals -operated across networks, often the network provides some sort of -flow control so that padding is never needed no matter how slow -an operation is. You must still specify a padding time if you want -Emacs to realize that the operation takes a long time. This will -cause padding characters to be sent unnecessarily, but they do -not really cost much. They will be transmitted while the scrolling -is happening and then discarded quickly by the terminal. - -Most bit-map terminals provide commands for inserting or deleting -multiple lines at once. Define the `AL' and `DL' strings in the -termcap entry to say how to do these things, and you will have -fast output without wasted padding characters. These strings should -each contain a single %-spec saying how to send the number of lines -to be scrolled. These %-specs are like those in the termcap -`cm' string. - -You should also define the `IC' and `DC' strings if your terminal -has a command to insert or delete multiple characters. These -take the number of positions to insert or delete as an argument. - -A `cs' string to set the scrolling region will reduce the amount -of motion you see on the screen when part of the screen is scrolled. - -* Your Delete key sends a Backspace to the terminal, using an AIXterm. - -The solution is to include in your .Xdefaults the lines: - - *aixterm.Translations: #override <Key>BackSpace: string(0x7f) - aixterm*ttyModes: erase ^? - -This makes your Backspace key send DEL (ASCII 127). - -* You type Control-H (Backspace) expecting to delete characters. - -Put `stty dec' in your .login file and your problems will disappear -after a day or two. - -The choice of Backspace for erasure was based on confusion, caused by -the fact that backspacing causes erasure (later, when you type another -character) on most display terminals. But it is a mistake. Deletion -of text is not the same thing as backspacing followed by failure to -overprint. I do not wish to propagate this confusion by conforming -to it. - -For this reason, I believe `stty dec' is the right mode to use, -and I have designed Emacs to go with that. If there were a thousand -other control characters, I would define Control-h to delete as well; -but there are not very many other control characters, and I think -that providing the most mnemonic possible Help character is more -important than adapting to people who don't use `stty dec'. - -If you are obstinate about confusing buggy overprinting with deletion, -you can redefine Backspace in your .emacs file: - (global-set-key "\b" 'delete-backward-char) -You may then wish to put the function help-command on some -other key. I leave to you the task of deciding which key. - -* Editing files through RFS gives spurious "file has changed" warnings. -It is possible that a change in Emacs 18.37 gets around this problem, -but in case not, here is a description of how to fix the RFS bug that -causes it. - - There was a serious pair of bugs in the handling of the fsync() system - call in the RFS server. - - The first is that the fsync() call is handled as another name for the - close() system call (!!). It appears that fsync() is not used by very - many programs; Emacs version 18 does an fsync() before closing files - to make sure that the bits are on the disk. - - This is fixed by the enclosed patch to the RFS server. - - The second, more serious problem, is that fsync() is treated as a - non-blocking system call (i.e., it's implemented as a message that - gets sent to the remote system without waiting for a reply). Fsync is - a useful tool for building atomic file transactions. Implementing it - as a non-blocking RPC call (when the local call blocks until the sync - is done) is a bad idea; unfortunately, changing it will break the RFS - protocol. No fix was supplied for this problem. - - (as always, your line numbers may vary) - - % rcsdiff -c -r1.2 serversyscall.c - RCS file: RCS/serversyscall.c,v - retrieving revision 1.2 - diff -c -r1.2 serversyscall.c - *** /tmp/,RCSt1003677 Wed Jan 28 15:15:02 1987 - --- serversyscall.c Wed Jan 28 15:14:48 1987 - *************** - *** 163,169 **** - /* - * No return sent for close or fsync! - */ - ! if (syscall == RSYS_close || syscall == RSYS_fsync) - proc->p_returnval = deallocate_fd(proc, msg->m_args[0]); - else - { - --- 166,172 ---- - /* - * No return sent for close or fsync! - */ - ! if (syscall == RSYS_close) - proc->p_returnval = deallocate_fd(proc, msg->m_args[0]); - else - { - -* Vax C compiler bugs affecting Emacs. - -You may get one of these problems compiling Emacs: - - foo.c line nnn: compiler error: no table entry for op STASG - foo.c: fatal error in /lib/ccom - -These are due to bugs in the C compiler; the code is valid C. -Unfortunately, the bugs are unpredictable: the same construct -may compile properly or trigger one of these bugs, depending -on what else is in the source file being compiled. Even changes -in header files that should not affect the file being compiled -can affect whether the bug happens. In addition, sometimes files -that compile correctly on one machine get this bug on another machine. - -As a result, it is hard for me to make sure this bug will not affect -you. I have attempted to find and alter these constructs, but more -can always appear. However, I can tell you how to deal with it if it -should happen. The bug comes from having an indexed reference to an -array of Lisp_Objects, as an argument in a function call: - Lisp_Object *args; - ... - ... foo (5, args[i], ...)... -putting the argument into a temporary variable first, as in - Lisp_Object *args; - Lisp_Object tem; - ... - tem = args[i]; - ... foo (r, tem, ...)... -causes the problem to go away. -The `contents' field of a Lisp vector is an array of Lisp_Objects, -so you may see the problem happening with indexed references to that. - -* 68000 C compiler problems - -Various 68000 compilers have different problems. -These are some that have been observed. - -** Using value of assignment expression on union type loses. -This means that x = y = z; or foo (x = z); does not work -if x is of type Lisp_Object. - -** "cannot reclaim" error. - -This means that an expression is too complicated. You get the correct -line number in the error message. The code must be rewritten with -simpler expressions. - -** XCONS, XSTRING, etc macros produce incorrect code. - -If temacs fails to run at all, this may be the cause. -Compile this test program and look at the assembler code: - -struct foo { char x; unsigned int y : 24; }; - -lose (arg) - struct foo arg; -{ - test ((int *) arg.y); -} - -If the code is incorrect, your compiler has this problem. -In the XCONS, etc., macros in lisp.h you must replace (a).u.val with -((a).u.val + coercedummy) where coercedummy is declared as int. - -This problem will not happen if the m-...h file for your type -of machine defines NO_UNION_TYPE. That is the recommended setting now. - -* C compilers lose on returning unions - -I hear that some C compilers cannot handle returning a union type. -Most of the functions in GNU Emacs return type Lisp_Object, which is -defined as a union on some rare architectures. - -This problem will not happen if the m-...h file for your type -of machine defines NO_UNION_TYPE. -
--- a/etc/=MACHINES Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,894 +0,0 @@ -This is a list of the status of GNU Emacs on various machines and systems. - -For each system and machine, we give the configuration name you should -pass to the `configure' script to prepare to build Emacs for that -system/machine. - -The `configure' script uses the configuration name to decide which -machine and operating system description files `src/config.h' should -include. The machine description files are all in `src/m', and have -names similar to, but not identical to, the machine names used in -configuration names. The operating system files are all in `src/s', -and are named similarly. See the `configure' script if you need to -know which configuration names use which machine and operating system -description files. - -If you add support for a new configuration, add a section to this -file, and then edit the `configure' script to tell it which -configuration name(s) should select your new machine description and -system description files. - - -Here are the configurations Emacs is intended to work with, with the -corresponding configuration names. You can postpend version numbers -to operating system names (i.e. sunos4.1) or architecture names (i.e. -hppa1.1). If you leave out the version number, the `configure' script -will configure Emacs for the latest version it knows about. - -Alliant (fx80-alliant-bsd): - - 18.52 worked on system version 4. Previous Emacs versions were - known to work on previous system versions. - - If you are using older versions of their operating system, you may - need to edit `src/config.h' to use `m/alliant1.h' (on version 1) or - `m/alliant.h' (on versions 2 and 3). - -Alliant FX/2800 (i860-alliant-bsd) - - Known to work with 18.58 and OS version 2.2, compiler version 1.3. - -Altos 3068 (m68k-altos-sysv) - - 18.52 was said to work, provided you don't compile unexec.c with -O. - -Amdahl UTS (580-amdahl-sysv) - - Small changes for 18.38 were merged in 18.39. It is mostly - working, but at last report a bug sometimes causes Emacs to - grab very large amounts of memory. No fix or explanation - has yet been reported. It may be possible to find this bug - if you find which Emacs command it happens within and then - run that command with a breakpoint set at malloc. - - The 5.2u370 compiler is so brain damaged that it is not - even worth trying to use it. Success was obtained with the - uts native C compiler on uts version 5.2.5. - -Apollo running Domain (m68k-apollo-bsd) - - 18.52 works, to some extent. - Code for dumping Emacs has been written, but we cannot distribute it yet. - There are reports of bugs in cc -O on this system. - - In `lib-src/Makefile', don't expect emacsclient and emacsserver to - compile. You might want to remove them from your makefile. - - Supposedly something in dired.c runs into a compiler bug. - Paraphrasing the statement should avoid the problem. I have not yet - received word as to the exact statement this is. - - The Apollo has a bizarre operating system which does not permit - Emacs to be dumped with preloaded pure Lisp code. Therefore, each - time you start Emacs on this system, the standard Lisp code is loaded - into it. Expect it to take a long time. You can prevent loading of - the standard Lisp code by specifying the -nl switch. It must - come at the beginning of the command line; only the -t and -batch - switches may come before it. - - There is one remaining problem on the Apollo. You must replace - the CPP line in src/Makefile with "CPP = /usr/lib/cpp". - The C preprocessor lives there rather than in /lib/cpp because the - Aegis OS uses the /lib directory as the repository for shared libraries. - - - Here is a design for a method of dumping and reloading the relevant - necessary impure areas of Emacs. - - On dumping, you need to dump only the array `pure' plus the - locations that contain values of forwarded Lisp variables or that are - protected for garbage collection. The former can be found by a - garbage- collection-like technique, and the latter are in the - staticprolist vector (see alloc.c for both things). - - Reloading would work in an Emacs that has just been started; except - when a switch is specified to inhibit this, it would read the dump - file and set all the appropriate locations. The data loaded must be - relocated, but that's not hard. Those locations that are of type - Lisp_Object can be found by a technique like garbage-collection, and - those of them that point to storage can be relocated. The other data - read from the file will not need to be relocated. - - The switch to inhibit loading the data base would be used when it - is time to dump a new data base. - - This would take a few seconds, which is much faster than loading - the Lisp code of Emacs from scratch. - -AT&T 3b2, 3b5, 3b15, 3b20 (we32k-att-sysv) - - Emacs will probably not work with certain kernel constants too small. - - In param.h CDLIMIT should be at least (1L << 12) in order to allow - processes to write up to 2 Mbyte files. This parameter is configurable - by normal means in /etc/master.d/kernel; examine that file for the - symbol CDLIMIT or ULIMIT, and raise it by several powers of 2. Then - do normal kernel rebuild things via "cd /boot; mkboot -k KERNEL" and so - forth. - - In seg.h NSEGP and STACKSEG should be at least 16 and 4 respectively - to allow processes with total size of up to 2Mbytes. - However, I'm told it is unlikely this would fail to be true. - - The MAXMEM may also prevent Emacs from running. The file - 3B-MAXMEM in this directory explains how to increase MAXMEM. - -AT&T 7300 or 3b1 (m68k-att-sysv) - - 18.52 worked. If you have strange troubles with dumping - Emacs, delete the last few lines from `src/m/7300.h' and recompile. - These lines are supposed to produce a sharable executable. - - `src/m/7300.h' defines SHORTNAMES because operating system versions - older than 3.5 did not support long symbol names. Version 3.5 does - support them, so you can remove the #define SHORTNAMES in that - version. - -Bull sps7 (m68k-bull-sysv) - - Changes partially merged in version 19, but some fixes are probably required. - -CCI 5/32, 6/32 - - See "Tahoe". - -Celerity (celerity-celerity-bsd4.2) - - Version 18.49 worked. This configuration name is a hack, because we - don't know the processor used by Celerities. If someone - who uses a Celerity could get in touch with us, we can teach - config.sub a better name for the configuration. - -Clipper (clipper-???) - - Version 19 has support for some brand of clipper system. If you - have successfully built Emacs 19 on some sort of clipper system, let - us know so we can flesh out this entry. - - Note that the Orion 105 is also a clipper, but some system-related - parameters are different. - -Convex (c1-convex-bsd, c2-convex-bsd, c32-convex-bsd, c34-convex-bsd, - c38-convex-bsd) - - 18.53 supposedly to work. - -Cubix QBx/386 (i386-cubix-sysv) - - Changes merged in 19.1. Systems before 2/A/0 may fail to compile etags.c - due to a compiler bug. - -Cydra 5 (cydra-cydrome-sysv) - - 18.51 worked in one version of their operating system but stopped - working in a newer version. This has not been fixed. - -DECstation (mips-dec-ultrix or mips-dec-osf) - - Version 19 works under Ultrix. - - See under Ultrix for problems using X windows on Ultrix. - Note that this is a MIPS machine. - - For Ultrix versions 4.1 or earlier, you may need to define - SYSTEM_MALLOC in `src/m/pmax.h', because XvmsAlloc.o in libX11.a seems - to insist on defining malloc itself. - - For Ultrix versions prior to 4.0, you may need to delete - the definition of START_FILES from `src/m/pmax.h'. - -Motorola Delta 147 (m68k-motorola-sysv) - - Motorola Delta boxes running System V/68 release 3. - (tested on sys1147 with SVR3V5). Changes merged in 19.1. - -Motorola Delta 187 (m88k-motorola-sysv or m88k-motorola-m88kbcs) - - Machine support added in version 19. - HAVE_X_MENU does not work due to lack of insque. - -Dual running System V (m68k-dual-sysv) - - As of 17.46, this worked except for a few changes - needed in unexec.c. - -Dual running Uniplus (m68k-dual-uniplus) - - Worked, as of 17.51. - -Elxsi 6400 (elxsi-elxsi-sysv) - - Changes for 12.0 release are in 19.1. - Dumping should work now. - -Encore machine (ns16k-encore-bsd) - - This machine bizarrely uses 4.2BSD modified to use the COFF format - for object files. Works (as of 18.40). For the APC processor you - must enable two lines at the end of `src/s/umax.h', which are commented - out in the file as distributed. - - WARNING: If you compile Emacs with the "-O" compiler switch, you - must also use the "-q enter_exits" switch so that all functions have - stack frames. Otherwise routines that call `alloca' all lose. - - A kernel bug in some system versions causes input characters to be lost - occasionally. - -GEC 63 (local-gec63-usg5.2) - - Changes are partially merged in version 18, but certainly require - more work. Let us know if you get this working, and we'll give it a - real configuration name. - -Gould Power Node (pn-gould-bsd4.2 or pn-gould-bsd4.3) - - 18.36 worked on versions 1.2 and 2.0 of the operating system. - - On UTX/32 2.0, use pn-gould-bsd4.3. - - On UTX/32 1.2 and UTX/32S 1.0, use pn-gould-bsd4.2 and note that - compiling `lib-src/sorted-doc' tickles a compiler bug: remove the -g - flag to cc in the makefile. - - UTX/32 1.3 has a bug in the bcopy library routine. Fix it by - #undef BSTRING in `src/m/gould.h'. - - Version 19 incorporates support for releases 2.1 and later of UTX/32. - A site running a pre-release of 2.1 should #define RELEASE2_1 in config.h. - -Gould NP1 (np1-gould-bsd) - - Version 19 supposedly works. - -Honeywell XPS100 (xps100-honeywell-sysv) - - Config file added in version 19. - -HP 9000 series 200 or 300 (m68k-hp-bsd or m68k-hp-hpux7.) - - Version 19 works under BSD. - - These machines are 68000-series CPUs running HP-UX - (a derivative of sysV with some BSD features) or BSD 4.3 ported by Utah. - The operating system suffix determines which system Emacs is built for. - - Series 200 HPUX runs Emacs only if it has the "HP-UX upgrade". - - If you are running HP-UX release 8.0 or later, you need the optional - "C/ANSI C" software in order to build Emacs (older releases of HP-UX - do not require any special software). If the file "/etc/filesets/C" - exists on your machine, you have this software, otherwise you do not. - - Note that HP has used two incompatible assembler syntaxes, - and has recently changed the format of C function frames. - `src/crt0.c' and `src/alloca.s' have been conditionalised for the new - assembler and new function-entry sequence. You may need to define - OLD_HP_ASSEMBLER if you are using an older hpux version. If you - have an official (bought from HP) series 300 machine you have - the new assembler. Kernels that are 5.+ or later have new - assembler. A Series 200 that has been upgraded to a 68010 - processor and a 5.+ kernel has the new compiler. - - Define C_SWITCH_MACHINE to be +X to make a version of Emacs that - runs on both 68010 and 68020 based hp-ux's. - - Define HPUX_68010 if you are using the new assembler, for - a system that has a 68010 without a 68881. This is to say, - a s200 (upgraded) or s310. - - Define the symbol HPUX_NET if you have the optional network features - that include the `netunam' system call. This is refered to as - Network Services (NS/9000) in HP literature. - -HP 9000 series 500: not supported. - - The series 500 has a seriously incompatible memory architecture - which relocates data in memory during execution of a program, - and support for it would be difficult to implement. - -HP 9000 series 800 (Spectrum) (hppa1.0-hp-hpux) - - These files support HP's Precision Architecture machines - running HP-UX. It has been moderately tested on the Series - 840. - - If you are running HP-UX release 8.0 or later, you need the optional - "C/ANSI C" software in order to build Emacs (older releases of HP-UX - do not require any special software). If the file "/etc/filesets/C" - exists on your machine, you have this software, otherwise you do not. - -High Level Hardware Orion (orion-highlevel-bsd) - - This is the original microprogrammed hardware. - Machine description file ought to work. - -High Level Hardware Orion 1/05 (clipper-highlevel-bsd) - - Changes merged in 18.52. This is the one with the Clipper cpu. - Note that systems which lack NFS need LOAD_AVE_TYPE changed to `double'. - - C compiler has a bug; it loops compiling eval.c. - Compile it by hand without optimization. - -IBM PS/2 (i386-ibm-aix1.1 or i386-ibm-aix1.2) - - Changes merged in version 19. You may need to copy - /usr/lib/samples/hft/hftctl.c to the Emacs src directory. - - i386-ibm-aix1.1 may not work with certain new X window managers, and - may be suboptimal. - -IBM RS/6000 (rs6000-ibm-aix) - - Changes merged in version 19. Currently the configuration - does not actually depend on the version of AIX. - - Compiling with -O using the IBM compiler has been known - to make Emacs work incorrectly. - -IBM RT/PC (romp-ibm-bsd or romp-ibm-aix) - - 18.52 worked on both operating systems. - Use romp-ibm-bsd for the 4.2-like system and romp-ibm-aix for AIX. - - On BSD, if you have trouble, try compiling with a different compiler. - - On AIX, the file /usr/lib/samples/hft/hftctl.c must be compiled into - hftctl.o, with this result left in the src directory (hftctl.c is - part of the standard AIX distribution). - - window.c must not be compiled with -O on AIX. - -Integrated Solutions `Optimum V' (m68k-isi-bsd4.2 or -bsd4.3) - - 18.52 said to work on some sort of ISI machine. - Version 18.45 worked (running on a Optimum V (VME bus, 68020) - BSD 4.2 (3.05e) system). 18.42 is reported to work on - a Qbus 68010 system. Has not been tried on `WorkStation' `Cluster - Compute Node' `Cluster WorkStation' or `Server Node' (Love the - StudLYCaps) - - Compilation with -O is rumored to break something. - - On recent system versions, you may need to undefine the macro UMAX - in `lib-src/loadst.c' and `src/getpagesize.h'. They stupidly defined this - in a system header file, which confuses Emacs (which thinks that UMAX - indicates the Umax operating system). - -Intel 386 (i386-unknown-isc, i386-unknown-esix, i386-unknown-xenix, - i386-intsys-sysv, i386-unknown-sysv5.2.2, i386-unknown-sysv5.3, - and i386-unknown-bsd4.2) - - 18.58 should support a wide variety of operating systems. - Make sure to use i386-unknown-isc2.2 for Interactive 386/ix version - 2.2 or later. - Use i386-unknown-esix for Esix. - Use i386-intsys-sysv for Integrated Solutions 386 machines. - It may also be correct for Microport systems. - It isn't clear what to do on an SCO system. The system's C - preprocessor doesn't seem to handle the src subdirectory's Make - trickery, so you will probably need to install the GNU C preprocessor. - - If you are using Xenix, see notes above under Xenix. - - Some sysV.3 systems seem to have bugs in `opendir'; - for them, alter `config.h' to define NONSYSTEM_DIR_LIBRARY - and undefine SYSV_SYSTEM_DIR. - - If you use optimization on V.3, you may need the option -W2,'-y 0' - to prevent certain faulty optimization. - - On 386/ix, to link with shared libraries, add #define USG_SHARED_LIBRARIES - to config.h. - - There is no consistency in the handling of certain system header files - on V.3. - - Some versions have sys/sioctl.h, and require it in sysdep.c. - But some versions do not have sys/sioctl.h. - For a given version of the system, this may depend on whether you have - X Windows or TCP/IP. Define or undefine NO_SIOCTL_H in config.h - according to whether you have the file. - - Likewise, some versions have been known to need sys/ttold.h, sys/stream.h, - and sys/ptem.h included in sysdep.c. If your system has these files, - try defining NEED_PTEM_H in config.h if you have trouble without it. - - You may find that adding -I/usr/X/include or -I/usr/netinclude or both - to CFLAGS avoids compilation errors on certain systems. - - Some versions convince sysdep.c to try to use `struct tchars' - but define `struct tc' instead; add `#define tchars tc' - to config.h to solve this problem. - -Iris 2500 and Iris 2500 Turbo (m68k-sgi-iris3.5 or m68k-sgi-iris3.6) - - Version 18 was said to work; use m68k-sgi-iris3.5 for system version 2.5 - and m68k-sgi-iris3.6 for system version 3.6. - Note that the 3030 is the same as the Iris 2500 Turbo. - -Iris 4D (mips-sgi-irix3.3 or mips-sgi-irix4.0) - - 18.58 is known to work on Silicon Graphics 4D series machines - with IRIX 3.3 or IRIX 4.0. Version 19 should support the - ANSI C compiler version 3.10. - - Most irix3.3 systems do not have an ANSI C compiler, but a few do. - If you are using the ANSI C compiler, you may need to add - #define C_SWITCH_MACHINE -cckr - to config.h. - - There is a bug in IRIX that can sometimes leave ptys owned by - root with a permission of 622. This causes malfunctions in use - of subprocesses of Emacs. This may be fixed in IRIX 4.0.5. - -Macintosh - - We are boycotting Apple because of Apple's efforts to take away - our freedom to write compatible imitations of existing software. - If you value your freedom to write such programs, we urge you - not to buy from Apple, not to develop software for Apple, and - certainly not to accept a job with Apple. - - See the file APPLE in this directory for more information. - -Masscomp (m68k-masscomp-rtu) - - 18.36 worked on a 5500DP running RTU v3.1a and compiler version 3.2 - with minor fixes that are included in 18.37. However, bizarre behavior - was reported for 18.36 on a Masscomp (model and version unknown but probably - a 68020 system). The report sounds like a compiler bug. - - A compiler bug affecting statements like - unsigned char k; unsigned char *p;... x = p[k]; - has been reported for "C version 1.2 under RTU 3.1". We do not wish - to take the time to install the numerous workarounds required to - compensate for this bug; go complain to Masscomp. - - For RTU version 3.1, define FIRST_PTY_LETTER to be 'p' in `src/s/rtu.h' - (or #undef and redefine it in config.h) so that ptys will be used. - - GNU Emacs is said to have no chance of compiling on RTU versions - prior to v3.0. - -Megatest (m68k-megatest-bsd) - - Emacs 15 worked; do not have any reports about Emacs 16 or 17 - but any new bugs are probably not difficult. - -Mips (mips-mips-riscos, mips-mips-riscos4.0, or mips-mips-bsd) - - Changes merged in 18.39. Some fixes in 18.56. - - Use mips-mips-riscos4.0 for RISCOS version 4. - Use mips-mips-bsd with the BSD world. - - Note that the proper configuration names for DECstations are - mips-dec-ultrix and mips-dec-osf. - - If you are compiling with GCC, then you must run fixincludes; - the alternative of using -traditional won't work because - the definition of SIGN_EXTEND_CHAR uses the keyword `signed'. - - If the SYSV world is the default, then you probably need the following - line in etc/Makefile: - - CFLAGS= -g -systype bsd43 - - Some operating systems on MIPS machines give SIGTRAP for division by - zero instead of the usual signals. The only real solution is to fix - the system to give a proper signal. - - In the meantime, you can change init_data in data.c if you wish. - Change it to handle SIGTRAP as well as SIGFPE. But this will have a - great disadvantage: you will not be able to run Emacs under a - debugger. I think crashing on division by zero is a lesser problem. - -National Semiconductor 32000 (ns32k-ns-genix) - - This is for a complete machine from National Semiconductor, - running Genix. Changes merged in version 19. - -NCR Tower 32 (m68k-ncr-sysv2 or m68k-ncr-sysv3) - - If you are running System V release 2, use m68k-ncr-sysv2. - If you are running System V release 3, use m68k-ncr-sysv3. - - These both worked as of 18.56. If you change `src/ymakefile' so that - CFLAGS includes C_OPTIMIZE_SWITCH rather than C_DEBUG_SWITCH, check - out the comments in `src/m/tower32.h' (for System V release 2) or - `src/m/tower32v3.h' (for System V release 3) about this. - - There is a report that compilation with -O did not work with 18.54 - under System V release 2. - -Nixdorf Targon 31 (m68k-nixdorf-sysv) - - Machine description file for version 17 is included in 18 - but whether it works is not known. - `src/unexec.c' bombs if compiled with -O. - Note that the "Targon 35" is really a Pyramid. - -Nu (TI or LMI) (m68k-nu-sysv) - - Version 18 is believed to work. - -Plexus (m68k-plexus-sysv) - - Worked as of 17.56. - -Pmax (DEC Mips) (mips-dec-ultrix or mips-dec-osf1) - - See under DECstation, above. - -Prime EXL (i386-prime-sysv) - - Minor changes merged in 19.1. - -Pyramid (pyramid-pyramid-bsd) - - You need to build Emacs in the Berkeley universe with - the `ucb' command, as in `ucb make' or `ucb build-install'. - - In OSx 4.0, it seems necessary to add the following two lines - to `src/m/pyramid.h': - #define _longjmp longjmp - #define _setjmp setjmp - - In Pyramid system 2.5 there has been a compiler bug making - Emacs crash just after screen-splitting with Qnil containing 0. - A compiler that fixes this is Pyramid customer number 8494, - internal number 1923. - - Some versions of the pyramid compiler get fatal - errors when the -gx compiler switch is used; if this - happens to you, change `src/m/pyramid.h' to define - C_DEBUG_SWITCH with an empty definition. - - Some old system versions may require you to define PYRAMID_OLD - in when alloca.s is preprocessed, in order to define _longjmp and _setjmp. - -Sequent Balance (ns32k-sequent-bsd4.2 or ns32k-sequent-bsd4.3) - - Emacs 18.51 worked on system version 3.0. 18.52 is said to work. - Delete some lines at the end of `src/m/sequent.h' for earlier system - versions. - -Sequent Symmetry (i386-sequent-bsd) - - Emacs 19 should work. - -SONY News (m68k-sony-bsd4.2 or m68k-sony-bsd4.3) - - 18.52 worked. Use m68k-sony-bsd4.3 for system release 3. - -SONY News 3000 series (RISC NEWS) (mips-sony-bsd) - - Worked, as of 18.56. Note that this is a MIPS architecture machine. - - Some versions of the operating system give SIGTRAP for division by zero - instead of the usual signals. This causes division by zero - to make Emacs crash. The system should be fixed to give the proper signal. - Changing Emacs is not a proper solution, because it would prevent - Emacs from working under any debugger. But you can change init_data - in data.c if you wish. - -Stardent 1500 or 3000 - - See Titan. - -Stride (m68k-stride-sysv) - - Works (most recent news for 18.30) on their release 2.0. - For release 2.2, see the end of `src/m/stride.h'. - It may be possible to run on their V.1 system but changes - in the s- file would be needed. - -Sun 1, 2 and 3 (m68k-sun-sunos, sparc-sun-sunos, i386-sun-sunos) - - It's important to include the SunOS version number in the - configuration name. For example, for SunOS release 4.0 on a Sun 3, - use `m68k-sun-sunos4.0'; for SunOS release 4.1 on a Sparc, use - `sparc-sun-sunos4.1'. - - Use `m68k' for the 68000-based Sun boxes, `sparc' for Sparcstations, - and `i386' for Sun Roadrunners. - - There are three machine files for the different versions of SunOS - that run on the Motorola 68000 processors. All are derived from - Berkeley 4.2. Emacs 17 has run on all of them. - - See the file etc/SUNBUG for how to solve problems caused by - bugs in the "export" version of SunOS 4. - - If you have trouble using open-network-stream, get the - distribution of `bind' (the BSD name-server), build libresolv.a, - and link Emacs with -lresolv. This problem is due to obsolete - software in the nonshared standard library. - - If you want to use SunWindows, define HAVE_SUN_WINDOWS - in config.h to enable a special interface called `emacstool'. - The definition must *precede* the #include "machine.h". - System version 3.2 is required for this facility to work. - - We recommend that you instead use the X window system, which - has technical advantages, is an industry standard, and is also - free software. - - If you are compiling for X windows, and the X window library was - compiled to use the 68881, then you must edit config.h according - the comments at the end of `src/m/sun3.h'. - - Note that Emacs on a Sun is not really as big as it looks. - As dumped, it includes around 200k of zeros between the - original text section and the original data section - (now remapped as part of the text). These are never - swapped in. - - To build a single Emacs that will run on Sun 2 and Sun 3 - HARDWARE, just build it on the Sun 2. - - Changes for the Sparc architecture were merged in 18.50. Some - people say optimizing compilation does not work; some say that -O2 - (whatever that is) works perhaps with a small change. - - Changes for the Roadrunner architecture were merged in 18.51. - - There is a bug in the Export version of SunOS 4.0 shipped outsde the - US; it has something to do with Pentagon export restrictions on the - DES chips in Suns. The symptom is that "cc -Bstatic ..." WILL NOT - WORK ON SUNOS 4.0 EXPORT without a little help from "ar". The - static C-library is /lib/libc.a, and this is where the problem - occurs. There are a bunch of .o files in there relating to DES - stuff (des_crypt.o, des_soft.o, _crypt.o, etc). All of them will - cause cc -Bstatic to die with these errors: - - > _edata: ld: user attempt to redefine loader-defined symbol - > _end: user attempt to redefine loader-defined symbol - > _etext: /lib/libc.a(des_crypt.o): multiply defined - - In order to make cc -Bstatic useful, you must remove all the - brain-damaged .o files from /lib/libc.a. To do this use - - ar d /lib/libc.a des_crypt.o des_soft.o _crypt.o .... - - (Make a backup of /lib/libc.a first, you may decide you need the "real" - thing someday). Note that there are a bunch of these files, these may - not be all of them. You will find them quick enough by trying to - compile ANY C program, even one which does NOTHING. - -Tadpole 68K (m68k-tadpole-sysv) - - Changes merged in 19.1. - - You may need to edit Makefile to change the variables LIBDIR and - BINDIR from /usr/local to /usr/contrib. - - To give movemail access to /usr/mail, you may need to execute - - chmod 2755 etc/movemail; chgrp mail etc/movemail - -Tahoe (tahoe-tahoe-bsd4.2 or tahoe-tahoe-bsd4.3) - - 18.52 was known to work on some Tahoes, but a compiler bug intervenes - on others. Some Emacs versions have worked in Unisys 1r4 - (not in 1r3) and CCI I.21. - - If you have trouble compiling `lib-src/loadst.c', turn off the definition - of DKSTAT_HEADER_FILE in `src/m/tahoe.h'. - -Tandem Integrity S2 (mips-tandem-sysv) - - Changes merged in 18.56 but subprocess support is turned off. - You will probably want to see if you can make subprocesses work. - - You must edit `lib-src/Makefile' to define LOADLIBES = -mld. - -Tektronix 16000 box (6130?) (ns16k-tektronix-bsd) - - Emacs 17.61 worked. - -Tektronix 4300 (m68k-tektronix-bsd) - - Emacs 18.51 worked. - -Titan P2 or P3 (titan-titan-sysv) - - Changes probably merged in version 19. - -Ustation E30 (SS5E) (m68k-unisys-unipl) - - Changes merged in 18.52; don't know whether they work. - -Vaxen running Berkeley Unix (vax-dec-bsd4.1, vax-dec-bsd4.2, vax-dec-bsd4.3), - Ultrix (vax-dec-ultrix), - System V (vax-dec-sysv0, vax-dec-sysv2), or - VMS (vax-dec-vms) - - Works. - - See under Ultrix for problems using X windows on Ultrix (vax-dec-ultrix). - - 18.27 worked on System V rel 2 (vax-dec-sysv2). - - 18.36 worked on System V rel 0 (vax-dec-sysv0). - - 18.36 was believed to work on VMS. Addition of features is necessary - to make this Emacs version more usable. - -Whitechapel MG1 (ns16k-whitechapel-?) - - May work. Supposedly no changes were needed except in `src/m/mg1.h' - file. I do not know what Unix version runs on them. - -Wicat (m68k-wicat-sysv) - - Changes merged as of 18.6; whether they work is unknown. - See comments in `src/m/wicat.h' for things you should change - depending on the system and compiler version you have. - -Here is a summary of the systems supported: - -Berkeley 4.1 (bsd4.1) - - Works on vaxes. - -Berkeley 4.2 (bsd4.2) - - Works on several machines. - -Berkeley 4.3 (bsd4.3) - - Works, on Vaxes at least. - -Microport - - See under "Intel 386". - -System V rel 0 (usg5.0) - - Works, on Vaxes and 3bxxx's. - There are some problems in 18.37 due to shortnames/cccp problems: - use the emacs 17 cpp if you have it. - -System V rel 2 (usg5.2) - - Works on various machines. - On some (maybe all) machines the library -lPW exists and contains - a version of `alloca'. On these machines, to use it, put - #define HAVE_ALLOCA - #define LIB_STANDARD -lPW -lc - in the `src/m/MACHINENAME.h' file for the machine. - - If you find that the character Meta-DEL makes Emacs crash, - find where function init_sys_modes in sysdep.c sets sg.c_cc[VQUIT] - and make it store 7 there. I have as yet no evidence of whether - this problem, known in HP-UX, exists in other system V versions. - -System V rel 2.2 (usg5.2.2) - - In 5.2.2 AT&T undid, incompatibly, their previous incompatible - change to the way the nlist library is called. A different s- file - is used to enable the other interface. - - They call themselves the right choice--can't they choose? - - Emacs version 18 unexec is currently not working properly - on 5.2.2. Nobody knows why yet. A workaround is to define - NO_REMAP. It is not yet known whether this applies to all - machines running 5.2.2. - -System V rel 3 (usg5.3) - - Some versions of this system support ptys and BSD-style sockets. - On such systems, you should define HAVE_PTYS and HAVE_SOCKETS in config.h. - - If you want to link Emacs with shared libraries, define - USG_SHARED_LIBRARIES. - - You may have to add ANSI idempotence #-lines to your sys/types.h - file to get Emacs to compile correctly. This may be necessary on - other pre-ANSI systems as well. - - On an AT&T 6386WGS using System V Release 3.2 and X11R3, the X support - cannot be made to work. Whether or not the GNU relocating malloc is - used, the symptom is that the first call Emacs makes to sbrk(0) returns - (char *)-1. Sorry, you're stuck with character-only mode. Try - installing Xfree86 to fix this. - -System V rel 4.0.3 and 4.0.4 (usg5.4) - - Supported, including shared libraries for ELF, but ptys do not work - because TIOCGPGRP fails to work on ptys (but Dell 2.2 seems to have - fixed this). This failure is probably due to a misunderstanding of - the consequences of the POSIX spec: many system designers mistakenly - think that POSIX requires this feature to fail. This is untrue; - ptys are an extension, and POSIX says that extensions *when used* - may change the action of standard facilities in any fashion. - - The standard C preprocessor may generate xmakefile incorrectly. However, - /lib/cpp will work, so use `make CPP=/lib/cpp'. Standard cpp - seems to work OK under Dell 2.2. - - Some versions 3 and earlier of V.4, on the Intel 386 and 860, had - problems in the X11 libraries. These prevent Emacs from working - with X. You can use Emacs with X provided your copy of X is based - on X11 release 4 or newer, or is Dell's 2.2 (which is a 4.0.3). - Unfortunately, the only way you can tell whether your X11 library is - new enough is to try compiling Emacs to use X. If emacs runs, your - X11 library is new enough. - - In this context, GSV4 and GSV4i are alternate names for X11R4. - OL2.* is X11R3 based. OL3 is in between X11R3 and X11R4, and may or - may not work, depending on who made the Unix system. If the library - libXol is part of the X distribution, then you have X11R3 and Emacs - won't work with X. - - Most versions of V.4 support sockets. If `/usr/lib/libsocket.so' - exists, your system supports them. If yours does not, you must add - #undef HAVE_SOCKETS in config.h, after the inclusion of s-usg5-4.h. - (Any system that supports Internet should implement sockets.) - -Ultrix (bsd4.3) - - Recent versions of Ultrix appear to support the features of Berkeley 4.3. - Ultrix was at the BSD 4.2 level for a long time after BSD 4.3 came out. - - Ultrix 3.0 has incompatibilities in its X library if you have the - Ultrix version of X (UWS version 2.0). To solve them, you need to - prevent XvmsAlloc.o in Xlib from being used. Israel Pinkas says: - - I added the following lines to config.h after the X defines: - - #if defined(ultrix) && defined(X11) - #define OBJECTS_SYSTEM calloc.o - #endif - - Then I ran the following: - - ar x /usr/lib/libc.a calloc.o - - The problem is said to be gone in UWS version 2.1. - -Uniplus 5.2 (unipl5.2) - - Works, on Dual machines at least. - -VMS (vmsM.N) - - The config file s/vms5-5.h may be right for some earlier versions; - please let us know what happens when you try it in VMS versions 5.0 - thru 5.4. - - Note that Emacs for VMS is usually distributed in a special VMS - distribution. See the file ../vms/VMSINSTALL for info on moving - Unix distributions to VMS, and other VMS-related topics. - -Xenix (xenix) - - Should work in 18.50, but you will need to edit the files - `lib-src/Makefile' and `src/ymakefile' - (see the comments that mention "Xenix" for what to change.) - Compiling Emacs with -O is said not to work. - - If you want Emacs to work with Smail (installed as /usr/bin/smail) - then add the line #define SMAIL to config.h. - - The file etc/XENIX suggests some useful things to do to Xenix - to make the Emacs meta key work. - -Local variables: -mode: text -fill-prefix: " " -End:
--- a/etc/=TO-DO Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -Things useful to do for GNU Emacs: - -* Primitive for random access insertion of part of a file. - -* Making I/O streams for files, so that read and prin1 can - be used on files directly. The I/O stream itself would - serve as a function to read or write one character. - -* If a file you can't write is in a directory you can write, - make sure it works to modify and save this file. - -* Make dired's commands handle correctly the case where - ls has listed several subdirectories' contents. - It needs to be able to tell which directory each file - is really in, by searching backward for the line - which identifies the start of a directory. - -* Add more dired commands, such as sorting (use the - sort utility through call-process-region). - -* Make display.c record inverse-video-ness on - a character by character basis. Then make non-full-screen-width - mode lines inverse video, and display the marked location in - inverse video. - -* VMS code to list a file directory. Make dired work. - -Long range: - - Ideas for extending GNU Emacs to deal with arbitrary character sets. - -I would like GNU Emacs to be extended to handle all the world's alphabets -and word signs. I don't expect to have time to do such a thing in the next -few years, so here are my ideas on the best way to do it. - -* Each graphic is represented by a sequence of ordinary 8-bit characters. - -* All the characters that make up such a sequence have codes >= 0200. - -* The first character of such a sequence is between 0200 and 0237. - -* The remaining characters of such a sequence are all 0240 or higher. - -* The first character of the sequence determines the number of characters -in the sequence. Thus, 0200...0207 could start two-character sequences, -0210...0227 could start three-character sequences, and 0230 could start -four-character sequences. (Codes 0231...0237 would be reserved.) - -* Several common alphabets, and some mathematical symbols, would get -two-character sequences. (Probably Greek, Russian, Hebrew(?), Arabic(?), -Korean, and Japanese kana). The remaining alphabets, and some versions of -Chinese, would get three-character sequences. Other sets of Chinese -characters would get four-character sequences. - -Each country that uses Chinese characters has its own standard character -set, and it is not easy to correlate them to avoid overlap. So there may -need to be several sets of Chinese characters. That is why they need so -much code space. - -True support for Hebrew and Arabic requires dealing with the problem of -writing direction for mixed text; I don't know what to do for that. - -* The functions that use syntax table would determine the -syntax of a sequence from its first character. - -* Functions in indent.c for computing widths and columns would -determine the width of a sequence from its first character. -So would display routines. - -* Only a few other editing routines would need any change. In -particular, searching and regexp matching might not need any change. - -* Most of the work required would be in redisplay. The only case that -needs to be supported is with X windows, since ordinary terminals -can't display all these characters anyway. - -* There might need to be code to translate files from this format -to whatever format is typically stored on disk. - - -I would be very unhappy with half-measures, such as support for -Japanese only. -
--- a/etc/=news.texi Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3380 +0,0 @@ -@setfilename LNEWS - -@section New Features in the Lisp Language - -@end itemize -@itemize @bullet -@item -The new function @code{delete} is a traditional Lisp function. It takes -two arguments, @var{elt} and @var{list}, and deletes from @var{list} any -elements that are equal to @var{elt}. It uses the function @code{equal} -to compare elements with @var{elt}. - -@item -The new function @code{member} is a traditional Lisp function. It takes -two arguments, @var{elt} and @var{list}, and finds the first element of -@var{list} that is equal to @var{elt}. It uses the function -@code{equal} to compare each list element with @var{elt}. - -The value is a sublist of @var{list}, whose first element is the one -that was found. If no matching element is found, the value is -@code{nil}. - -@ignore @c Seems not to be true, from looking at the code. -@item -The function @code{equal} is now more robust: it does not crash due to -circular list structure. -@end ignore - -@item -The new function @code{indirect-function} finds the effective function -definition of an object called as a function. If the object is a -symbol, @code{indirect-function} looks in the function definition of the -symbol. It keeps doing this until it finds something that is not a -symbol. - -@item -There are new escape sequences for use in character and string -constants. The escape sequence @samp{\a} is equivalent to @samp{\C-g}, -the @sc{ASCII} @sc{BEL} character (code 7). The escape sequence -@samp{\x} followed by a hexidecimal number represents the character -whose @sc{ASCII} code is that number. There is no limit on the number -of digits in the hexidecimal value. - -@item -The function @code{read} when reading from a buffer now does not skip a -terminator character that terminates a symbol. It leaves that character -to be read (or just skipped, if it is whitespace) next time. - -@item -When you use a function @var{function} as the input stream for -@code{read}, it is usually called with no arguments, and should return -the next character. In Emacs 19, sometimes @var{function} is called -with one argument (always a character). When that happens, -@var{function} should save the argument and arrange to return it when -called next time. - -@item -@code{random} with integer argument @var{n} returns a random number -between 0 and @var{n}@minus{}1. - -@item -The functions @code{documentation} and @code{documentation-property} now -take an additional optional argument which, if non-@code{nil}, says to -refrain from calling @code{substitute-command-keys}. This way, you get -the exact text of the documentation string as written, without the usual -substitutions. Make sure to call @code{substitute-command-keys} -yourself if you decide to display the string. - -@ignore -@item -The new function @code{invocation-name} returns as a string the program -name that was used to run Emacs, with any directory names discarded. -@c ??? This hasn't been written yet. ??? -@end ignore - -@item -The new function @code{map-y-or-n-p} makes it convenient to ask a series -of similar questions. The arguments are @var{prompter}, @var{actor}, -@var{list}, and optional @var{help}. - -The value of @var{list} is a list of objects, or a function of no -arguments to return either the next object or @code{nil} meaning there -are no more. - -The argument @var{prompter} specifies how to ask each question. If -@var{prompter} is a string, the question text is computed like this: - -@example -(format @var{prompter} @var{object}) -@end example - -@noindent -where @var{object} is the next object to ask about. - -If not a string, @var{prompter} should be a function of one argument -(the next object to ask about) and should return the question text. - -The argument @var{actor} should be a function of one argument, which is -called with each object that the user says yes for. Its argument is -always one object from @var{list}. - -If @var{help} is given, it is a list @code{(@var{object} @var{objects} -@var{action})}, where @var{object} is a string containing a singular -noun that describes the objects conceptually being acted on; -@var{objects} is the corresponding plural noun and @var{action} is a -transitive verb describing @var{actor}. The default is @code{("object" -"objects" "act on")}. - -Each time a question is asked, the user may enter @kbd{y}, @kbd{Y}, or -@key{SPC} to act on that object; @kbd{n}, @kbd{N}, or @key{DEL} to skip -that object; @kbd{!} to act on all following objects; @key{ESC} or -@kbd{q} to exit (skip all following objects); @kbd{.} (period) to act on -the current object and then exit; or @kbd{C-h} to get help. - -@code{map-y-or-n-p} returns the number of objects acted on. - -@item -You can now ``set'' environment variables with the @code{setenv} -command. This works by setting the variable @code{process-environment}, -which @code{getenv} now examines in preference to the environment Emacs -received from its parent. -@end itemize - -@section New Features for Loading Libraries - -You can now arrange to run a hook if a particular Lisp library is -loaded. - -The variable @code{after-load-alist} is an alist of expressions to be -evalled when particular files are loaded. Each element looks like -@code{(@var{filename} @var{forms}@dots{})}. - -When @code{load} is run and the file name argument equals -@var{filename}, the @var{forms} in the corresponding element are -executed at the end of loading. @var{filename} must match exactly! -Normally @var{filename} is the name of a library, with no directory -specified, since that is how @code{load} is normally called. - -An error in @var{forms} does not undo the load, but does prevent -execution of the rest of the @var{forms}. - -The function @code{eval-after-load} provides a convenient way to add -entries to the alist. Call it with two arguments, @var{file} and a -form to execute. - -The function @code{autoload} now supports autoloading a keymap. -Use @code{keymap} as the fourth argument if the autoloaded function -will become a keymap when loaded. - -There is a new feature for specifying which functions in a library should -be autoloaded by writing special ``magic'' comments in that library itself. - - Write @samp{;;;###autoload} on a line by itself before a function -definition before the real definition of the function, in its -autoloadable source file; then the command @kbd{M-x -update-file-autoloads} automatically puts the @code{autoload} call into -@file{loaddefs.el}. - - You can also put other kinds of forms into @file{loaddefs.el}, by -writing @samp{;;;###autoload} followed on the same line by the form. -@kbd{M-x update-file-autoloads} copies the form from that line. - -@section Compilation Features - -@itemize @bullet -@item -Inline functions. - -You can define an @dfn{inline function} with @code{defsubst}. Use -@code{defsubst} just like @code{defun}, and it defines a function which -you can call in all the usual ways. Whenever the function thus defined -is used in compiled code, the compiler will open code it. - -You can get somewhat the same effects with a macro, but a macro has the -limitation that you can use it only explicitly; a macro cannot be called -with @code{apply}, @code{mapcar} and so on. Also, it takes some work to -convert an ordinary function into a macro. To convert it into an inline -function, simply replace @code{defun} with @code{defsubst}. - -Making a function inline makes explicit calls run faster. But it also -has disadvantages. For one thing, it reduces flexibility; if you change -the definition of the function, calls already inlined still use the old -definition until you recompile them. - -Another disadvantage is that making a large function inline can increase -the size of compiled code both in files and in memory. Since the -advantages of inline functions are greatest for small functions, you -generally should not make large functions inline. - -Inline functions can be used and open coded later on in the same file, -following the definition, just like macros. - -@item -The command @code{byte-compile-file} now offers to save any buffer -visiting the file you are compiling. - -@item -The new command @code{compile-defun} reads, compiles and executes the -defun containing point. If you use this on a defun that is actually a -function definition, the effect is to install a compiled version of -that function. - -@item -Whenever you load a Lisp file or library, you now receive a warning if -the directory contains both a @samp{.el} file and a @samp{.elc} file, -and the @samp{.el} file is newer. This typically indicates that someone -has updated the Lisp code but forgotten to recompile it, so the changes -do not take effect. The warning is a reminder to recompile. - -@item -The special form @code{eval-when-compile} marks the forms it contains to -be evaluated at compile time @emph{only}. At top-level, this is -analogous to the Common Lisp idiom @code{(eval-when (compile) -@dots{})}. Elsewhere, it is similar to the Common Lisp @samp{#.} reader -macro (but not when interpreting). - -If you're thinking of using this feature, we recommend you consider whether -@code{provide} and @code{require} might do the job as well. - -@item -The special form @code{eval-and-compile} is similar to -@code{eval-when-compile}, but the whole form is evaluated both at -compile time and at run time. - -If you're thinking of using this feature, we recommend you consider -whether @code{provide} and @code{require} might do the job as well. - -@item -Emacs Lisp has a new data type for byte-code functions. This makes -them faster to call, and also saves space. Internally, a byte-code -function object is much like a vector; however, the evaluator handles -this data type specially when it appears as a function to be called. - -The printed representation for a byte-code function object is like that -for a vector, except that it starts with @samp{#} before the opening -@samp{[}. A byte-code function object must have at least four elements; -there is no maximum number, but only the first six elements are actually -used. They are: - -@table @var -@item arglist -The list of argument symbols. - -@item byte-code -The string containing the byte-code instructions. - -@item constants -The vector of constants referenced by the byte code. - -@item stacksize -The maximum stack size this function needs. - -@item docstring -The documentation string (if any); otherwise, @code{nil}. - -@item interactive -The interactive spec (if any). This can be a string or a Lisp -expression. It is @code{nil} for a function that isn't interactive. -@end table - -The predicate @code{byte-code-function-p} tests whether a given object -is a byte-code function. - -You can create a byte-code function object in a Lisp program -with the function @code{make-byte-code}. Its arguments are the elements -to put in the byte-code function object. - -You should not try to come up with the elements for a byte-code function -yourself, because if they are inconsistent, Emacs may crash when you -call the function. Always leave it to the byte compiler to create these -objects; it, we hope, always makes the elements consistent. -@end itemize - -@section Floating Point Numbers - -You can now use floating point numbers in Emacs, if you define the macro -@code{LISP_FLOAT_TYPE} when you compile Emacs. - -The printed representation for floating point numbers requires either a -decimal point surrounded by digits, or an exponent, or both. For -example, @samp{1500.0}, @samp{15e2}, @samp{15.0e2} and @samp{1.5e3} are -four ways of writing a floating point number whose value is 1500. - -The existing predicate @code{numberp} now returns @code{t} if the -argument is any kind of number---either integer or floating. The new -predicates @code{integerp} and @code{floatp} check for specific types of -numbers. - -You can do arithmetic on floating point numbers with the ordinary -arithmetic functions, @code{+}, @code{-}, @code{*} and @code{/}. If you -call one of these functions with both integers and floating point -numbers among the arguments, the arithmetic is done in floating point. -The same applies to the numeric comparison functions such as @code{=} -and @code{<}. The remainder function @code{%} does not accept floating -point arguments, and neither do the bitwise boolean operations such as -@code{logand} or the shift functions such as @code{ash}. - -There is a new arithmetic function, @code{abs}, which returns the absolute -value of its argument. It handles both integers and floating point -numbers. - -To convert an integer to floating point, use the function @code{float}. -There are four functions to convert floating point numbers to integers; -they differ in how they round. @code{truncate} rounds toward 0, -@code{floor} rounds down, @code{ceil} rounds up, and @code{round} -produces the nearest integer. - -You can use @code{logb} to extract the binary exponent of a floating -point number. More precisely, it is the logarithm base 2, rounded down -to an integer. - -Emacs has several new mathematical functions that accept any kind of -number as argument, but always return floating point numbers. - -@table @code -@item cos -@findex cos -@itemx sin -@findex sin -@itemx tan -@findex tan -Trigonometric functions. -@item acos -@findex acos -@itemx asin -@findex asin -@itemx atan -@findex atan -Inverse trigonometric functions. -@item exp -@findex exp -The exponential function (power of @var{e}). -@item log -@findex log -Logarithm base @var{e}. -@item expm1 -@findex expm1 -Power of @var{e}, minus 1. -@item log1p -@findex log1p -Add 1, then take the logarithm. -@item log10 -@findex log10 -Logarithm base 10 -@item expt -@findex expt -Raise @var{x} to power @var{y}. -@item sqrt -@findex sqrt -The square root function. -@end table - -The new function @code{string-to-number} now parses a string containing -either an integer or a floating point number, returning the number. - -The @code{format} function now handles the specifications @samp{%e}, -@samp{%f} and @samp{%g} for printing floating point numbers; likewise -@code{message}. - -The new variable @code{float-output-format} controls how Lisp prints -floating point numbers. Its value should be @code{nil} or a string. - -If it is a string, it should contain a @samp{%}-spec like those accepted -by @code{printf} in C, but with some restrictions. It must start with -the two characters @samp{%.}. After that comes an integer which is the -precision specification, and then a letter which controls the format. - -The letters allowed are @samp{e}, @samp{f} and @samp{g}. Use @samp{e} -for exponential notation (@samp{@var{dig}.@var{digits}e@var{expt}}). -Use @samp{f} for decimal point notation -(@samp{@var{digits}.@var{digits}}). Use @samp{g} to choose the shorter -of those two formats for the number at hand. - -The precision in any of these cases is the number of digits following -the decimal point. With @samp{f}, a precision of 0 means to omit the -decimal point. 0 is not allowed with @samp{f} or @samp{g}. - -A value of @code{nil} means to use the format @samp{%.20g}. - -No matter what the value of @code{float-output-format}, printing ensures -that the result fits the syntax rules for a floating point number. If -it doesn't fit (for example, if it looks like an integer), it is -modified to fit. By contrast, the @code{format} function formats -floating point numbers without requiring the output to fit the -syntax rules for floating point number. - -@section New Features for Printing And Formatting Output - -@itemize @bullet -@item -The @code{format} function has a new feature: @samp{%S}. This print -spec prints any kind of Lisp object, even a string, using its Lisp -printed representation. - -By contrast, @samp{%s} prints everything without quotation. - -@item -@code{prin1-to-string} now takes an optional second argument which says -not to print the Lisp quotation characters. (In other words, to use -@code{princ} instead of @code{prin1}.) - -@item -The new variable @code{print-level} specifies the maximum depth of list -nesting to print before cutting off all deeper structure. A value of -@code{nil} means no limit. -@end itemize - -@section Changes in Basic Editing Functions - -@itemize @bullet -@item -There are two new primitives for putting text in the kill ring: -@code{kill-new} and @code{kill-append}. - -The function @code{kill-new} adds a string to the front of the kill ring. - -Use @code{kill-append} to add a string to a previous kill. The second -argument @var{before-p}, if non-@code{nil}, says to add the string at -the beginning; otherwise, it goes at the end. - -Both of these functions apply @code{interprogram-cut-function} to the -entire string of killed text that ends up at the beginning of the kill -ring. - -@item -The new function @code{current-kill} rotates the yanking pointer in the -kill ring by @var{n} places, and returns the text at that place in the -ring. If the optional second argument @var{do-not-move} is -non-@code{nil}, it doesn't actually move the yanking point; it just -returns the @var{n}th kill forward. If @var{n} is zero, indicating a -request for the latest kill, @code{current-kill} calls -@code{interprogram-paste-function} (documented below) before consulting -the kill ring. - -All Emacs Lisp programs should either use @code{current-kill}, -@code{kill-new}, and @code{kill-append} to manipulate the kill ring, or -be sure to call @code{interprogram-paste-function} and -@code{interprogram-cut-function} as appropriate. - -@item -The variables @code{interprogram-paste-function} and -@code{interprogram-cut-function} exist so that you can provide functions -to transfer killed text to and from other programs. - -@item -The @code{kill-region} function can now be used in read-only buffers. -It beeps, but adds the region to the kill ring without deleting it. - -@item -The new function @code{compare-buffer-substrings} lets you compare two -substrings of the same buffer or two different buffers. Its arguments -look like this: - -@example -(compare-buffer-substrings @var{buf1} @var{beg1} @var{end1} @var{buf2} @var{beg2} @var{end2}) -@end example - -The first three arguments specify one substring, giving a buffer and two -positions within the buffer. The last three arguments specify the other -substring in the same way. - -The value is negative if the first substring is less, positive if the -first is greater, and zero if they are equal. The absolute value of -the result is one plus the index of the first different characters. - -@item -Overwrite mode treats tab and newline characters specially. You can now -turn off this special treatment by setting @code{overwrite-binary-mode} -to @code{t}. - -@item -Once the mark ``exists'' in a buffer, it normally never ceases to -exist. However, it may become @dfn{inactive}. The variable -@code{mark-active}, which is always local in all buffers, indicates -whether the mark is active: non-@code{nil} means yes. - -A command can request deactivation of the mark upon return to the editor -command loop by setting @code{deactivate-mark} to a non-@code{nil} -value. Transient Mark mode works by causing the buffer modification -primitives to set @code{deactivate-mark}. - -The variables @code{activate-mark-hook} and @code{deactivate-mark-hook} -are normal hooks run, respectively, when the mark becomes active andwhen -it becomes inactive. The hook @code{activate-mark-hook} is also run at -the end of a command if the mark is active and the region may have -changed. - -@item -The function @code{move-to-column} now accepts a second optional -argument @var{force}, in addition to @var{column}; if the requested -column @var{column} is in the middle of a tab character and @var{force} -is non-@code{nil}, @code{move-to-column} replaces the tab with the -appropriate sequence of spaces so that it can place point exactly at -@var{column}. - -@item -The search functions when successful now return the value of point -rather than just @code{t}. This affects the functions -@code{search-forward}, @code{search-backward}, -@code{word-search-forward}, @code{word-search-backward}, -@code{re-search-forward}, and @code{re-search-backward}. - -@item -When you do regular expression searching or matching, there is no longer -a limit to how many @samp{\(@dots{}\)} pairs you can get information -about with @code{match-beginning} and @code{match-end}. Also, these -parenthetical groupings may now be nested to any degree. - -@item -The new special form @code{save-match-data} preserves the regular -expression match status. Usage: @code{(save-match-data -@var{body}@dots{})}. - -@item -The function @code{translate-region} applies a translation table to the -characters in a part of the buffer. Invoke it as -@code{(translate-region @var{start} @var{end} @var{table})}; @var{start} -and @var{end} bound the region to translate. - -The translation table @var{table} is a string; @code{(aref @var{table} -@var{ochar})} gives the translated character corresponding to -@var{ochar}. If the length of @var{table} is less than 256, any -characters with codes larger than the length of @var{table} are not -altered by the translation. - -@code{translate-region} returns the number of characters which were -actually changed by the translation. This does not count characters -which were mapped into themselves in the translation table. - -@item -There are two new hook variables that let you notice all changes in all -buffers (or in a particular buffer, if you make them buffer-local): -@code{before-change-function} and @code{after-change-function}. - -If @code{before-change-function} is non-@code{nil}, then it is called -before any buffer modification. Its arguments are the beginning and end -of the region that is going to change, represented as integers. The -buffer that's about to change is always the current buffer. - -If @code{after-change-function} is non-@code{nil}, then it is called -after any buffer modification. It takes three arguments: the beginning -and end of the region just changed, and the length of the text that -existed before the change. (To get the current length, subtract the -rrgion beginning from the region end.) All three arguments are -integers. The buffer that's about to change is always the current -buffer. - -Both of these variables are temporarily bound to @code{nil} during the -time that either of these hooks is running. This means that if one of -these functions changes the buffer, that change won't run these -functions. If you do want hooks to be run recursively, write your hook -functions to bind these variables back to their usual values. - -@item -The hook @code{first-change-hook} is run using @code{run-hooks} whenever -a buffer is changed that was previously in the unmodified state. - -@item -The second argument to @code{insert-abbrev-table-description} is -now optional. -@end itemize - -@section Text Properties - - Each character in a buffer or a string can have a @dfn{text property -list}, much like the property list of a symbol. The properties belong -to a particular character at a particular place, such as, the letter -@samp{T} at the beginning of this sentence. Each property has a name, -which is usually a symbol, and an associated value, which can be any -Lisp object---just as for properties of symbols (@pxref{Property Lists}). - - You can use the property @code{face-code} to control the font and -color of text. That is the only property name which currently has a -special meaning, but you can create properties of any name and examine -them later for your own purposes. - - Copying text between strings and buffers preserves the properties -along with the characters; this includes such diverse functions as -@code{substring}, @code{insert}, and @code{buffer-substring}. - - Since text properties are considered part of the buffer contents, -changing properties in a buffer ``modifies'' the buffer, and you can -also undo such changes. - - Strings with text properties have a special printed representation -which describes all the properties. This representation is also the -read syntax for such a string. It looks like this: - -@example -#("@var{characters}" @var{property-data}...) -@end example - -@noindent -where @var{property-data} is zero or more elements in groups of three as -follows: - -@example -@var{beg} @var{end} @var{plist} -@end example - -@noindent -The elements @var{beg} and @var{end} are integers, and together specify -a portion of the string; @var{plist} is the property list for that -portion. - -@subsection Examining Text Properties - - The simplest way to examine text properties is to ask for the value of -a particular property of a particular character. For that, use -@code{get-text-property}. Use @code{text-properties-at} to get the -entire property list of a character. @xref{Property Search}, for -functions to examine the properties of a number of characters at once. - -@code{(get-text-property @var{pos} @var{prop} @var{object})} returns the -@var{prop} property of the character after @var{pos} in @var{object} (a -buffer or string). The argument @var{object} is optional and defaults -to the current buffer. - -@code{(text-properties-at @var{pos} @var{object})} returns the entire -property list of the character after @var{pos} in the string or buffer -@var{object} (which defaults to the current buffer). - -@subsection Changing Text Properties - - There are three primitives for changing properties of a specified -range of text: - -@table @code -@item add-text-properties -This function puts on specified properties, leaving other existing -properties unaltered. - -@item put-text-property -This function puts on a single specified property, leaving others -unaltered. - -@item remove-text-properties -This function removes specified properties, leaving other -properties unaltered. - -@item set-text-properties -This function replaces the entire property list, leaving no vessage of -the properties that that text used to have. -@end table - -All these functions take four arguments: @var{start}, @var{end}, -@var{props}, and @var{object}. The last argument is optional and -defaults to the current buffer. The argument @var{props} has the form -of a property list. - -@subsection Property Search Functions - -In typical use of text properties, most of the time several or many -consecutive characters have the same value for a property. Rather than -writing your programs to examine characters one by one, it is much -faster to process chunks of text that have the same property value. - -The functions @code{next-property-change} and -@code{previous-property-change} scan forward or backward from position -@var{pos} in @var{object}, looking for a change in any property between -two characters scanned. They returns the position between those two -characters, or @code{nil} if no change is found. - -The functions @code{next-single-property-change} and -@code{previous-single-property-change} are similar except that you -specify a particular property and they look for changes in the value of -that property only. The property is the second argument, and -@var{object} is third. - -@subsection Special Properties - - If a character has a @code{category} property, we call it the -@dfn{category} of the character. It should be a symbol. The properties -of the symbol serve as defaults for the properties of the character. - - You can use the property @code{face-code} to control the font and -color of text. That is the only property name which currently has a -special meaning, but you can create properties of any name and examine -them later for your own purposes. -about face codes. - - You can specify a different keymap for a portion of the text by means -of a @code{local-map} property. The property's value, for the character -after point, replaces the buffer's local map. - - If a character has the property @code{read-only}, then modifying that -character is not allowed. Any command that would do so gets an error. - - If a character has the property @code{modification-hooks}, then its -value should be a list of functions; modifying that character calls all -of those functions. Each function receives two arguments: the beginning -and end of the part of the buffer being modified. Note that if a -particular modification hook function appears on several characters -being modified by a single primitive, you can't predict how many times -the function will be called. - - Insertion of text does not, strictly speaking, change any existing -character, so there is a special rule for insertion. It compares the -@code{read-only} properties of the two surrounding characters; if they -are @code{eq}, then the insertion is not allowed. Assuming insertion is -allowed, it then gets the @code{modification-hooks} properties of those -characters and calls all the functions in each of them. (If a function -appears on both characters, it may be called once or twice.) - - The special properties @code{point-entered} and @code{point-left} -record hook functions that report motion of point. Each time point -moves, Emacs compares these two property values: - -@itemize @bullet -@item -the @code{point-left} property of the character after the old location, -and -@item -the @code{point-entered} property of the character after the new -location. -@end itemize - -@noindent -If these two values differ, each of them is called (if not @code{nil}) -with two arguments: the old value of point, and the new one. - - The same comparison is made for the characters before the old and new -locations. The result may be to execute two @code{point-left} functions -(which may be the same function) and/or two @code{point-entered} -functions (which may be the same function). The @code{point-left} -functions are always called before the @code{point-entered} functions. - - A primitive function may examine characters at various positions -without moving point to those positions. Only an actual change in the -value of point runs these hook functions. - -@section New Features for Files - -@itemize @bullet -@item -The new function @code{file-accessible-directory-p} tells you whether -you can open files in a particular directory. Specify as an argument -either a directory name or a file name which names a directory file. -The function returns @code{t} if you can open existing files in that -directory. - -@item -The new function @code{file-executable-p} returns @code{t} if its -argument is the name of a file you have permission to execute. - -@item -The function @code{file-truename} returns the ``true name'' of a -specified file. This is the name that you get by following symbolic -links until none remain. The argument must be an absolute file name. - -@item -New functions @code{make-directory} and @code{delete-directory} create and -delete directories. They both take one argument, which is the name of -the directory as a file. - -@item -The function @code{read-file-name} now takes an additional argument -which specifies an initial file name. If you specify this argument, -@code{read-file-name} inserts it along with the directory name. It puts -the cursor between the directory and the initial file name. - -The user can then use the initial file name unchanged, modify it, or -simply kill it with @kbd{C-k}. - -If the variable @code{insert-default-directory} is @code{nil}, then the -default directory is not inserted, and the new argument is ignored. - -@item -The function @code{file-relative-name} does the inverse of -expansion---it tries to return a relative name which is equivalent to -@var{filename} when interpreted relative to @var{directory}. (If such a -relative name would be longer than the absolute name, it returns the -absolute name instead.) - -@item -The function @code{file-newest-backup} returns the name of the most -recent backup file for @var{filename}, or @code{nil} that file has no -backup files. - -@item -The list returned by @code{file-attributes} now has 12 elements. The -12th element is the file system number of the file system that the file -is in. This element together with the file's inode number, which is the -11th element, give enough information to distinguish any two files on -the system---no two files can have the same values for both of these -numbers. - -@item -The new function @code{set-visited-file-modtime} updates the current -buffer's recorded modification time from the visited file's time. - -This is useful if the buffer was not read from the file normally, or -if the file itself has been changed for some known benign reason. - -If you give the function an argument, that argument specifies the new -value for the recorded modification time. The argument should be a list -of the form @code{(@var{high} . @var{low})} or @code{(@var{high} -@var{low})} containing two integers, each of which holds 16 bits of the -time. (This is the same format that @code[file-attributes} uses to -return time values.) - -The new function @code{visited-file-modtime} returns the recorded last -modification time, in that same format. - -@item -The function @code{directory-files} now takes an optional fourth -argument which, if non-@code{nil}, inhibits sorting the file names. -Use this if you want the utmost possible speed and don't care what order -the files are processed in. - -If the order of processing is at all visible to the user, then the user -will probably be happier if you do sort the names. - -@item -The variable @code{directory-abbrev-alist} contains an alist of -abbreviations to use for file directories. Each element has the form -@code{(@var{from} . @var{to})}, and says to replace @var{from} with -@var{to} when it appears in a directory name. This replacement is done -when setting up the default directory of a newly visited file. The -@var{from} string is actually a regular expression; it should always -start with @samp{^}. - -You can set this variable in @file{site-init.el} to describe the -abbreviations appropriate for your site. - -@item -The function @code{abbreviate-file-name} applies abbreviations from -@code{directory-abbrev-alist} to its argument, and substitutes @samp{~} -for the user's home directory. - -Abbreviated directory names are useful for directories that are normally -accessed through symbolic links. If you think of the link's name as -``the name'' of the directory, you can define it as an abbreviation for -the directory's official name; then ordinarily Emacs will call that -directory by the link name you normally use. - -@item -@code{write-region} can write a given string instead of text from the -buffer. Use the string as the first argument (in place of the -starting character position). - -You can supply a second file name as the fifth argument (@var{visit}). -Use this to write the data to one file (the first argument, -@var{filename}) while nominally visiting a different file (the fifth -argument, @var{visit}). The argument @var{visit} is used in the echo -area message and also for file locking; @var{visit} is stored in -@code{buffer-file-name}. - -@item -The value of @code{write-file-hooks} does not change when you switch to -a new major mode. The intention is that these hooks have to do with -where the file came from, and not with what it contains. - -@item -There is a new hook variable for saving files: -@code{write-contents-hooks}. It works just like @code{write-file-hooks} -except that switching to a new major mode clears it back to @code{nil}. -Major modes should use this hook variable rather than -@code{write-file-hooks}. - -@item -The hook @code{after-save-hook} runs just after a buffer has been saved -in its visited file. - -@item -The new function @code{set-default-file-modes} sets the file protection -for new files created with Emacs. The argument must be an integer. (It -would be better to permit symbolic arguments like the @code{chmod} -program, but that would take more work than this function merits.) - -Use the new function @code{default-file-modes} to read the current -default file mode. - -@item -Call the new function @code{unix-sync} to force all pending disk output -to happen as soon as possible. -@end itemize - -@section Making Certain File Names ``Magic'' - -You can implement special handling for a class of file names. You must -supply a regular expression to define the class of names (all those -which match the regular expression), plus a handler that implements all -the primitive Emacs file operations for file names that do match. - -The value of @code{file-name-handler-alist} is a list of handlers, -together with regular expressions that decide when to apply each -handler. Each element has the form @code{(@var{regexp} -. @var{handler})}. If a file name matches @var{regexp}, then all work -on that file is done by calling @var{handler}. - -All the Emacs primitives for file access and file name transformation -check the given file name against @code{file-name-handler-alist}, and -call @var{handler} to do the work if appropriate. The first argument -given to @var{handler} is the name of the primitive; the remaining -arguments are the arguments that were passed to that primitive. (The -first of these arguments is typically the file name itself.) For -example, if you do this: - -@example -(file-exists-p @var{filename}) -@end example - -@noindent -and @var{filename} has handler @var{handler}, then @var{handler} is -called like this: - -@example -(funcall @var{handler} 'file-exists-p @var{filename}) -@end example - -Here are the primitives that you can handle in this way: - -@quotation -@code{add-name-to-file}, @code{copy-file}, @code{delete-directory}, -@code{delete-file}, @code{directory-file-name}, @code{directory-files}, -@code{dired-compress-file}, @code{dired-uncache}, -@code{expand-file-name}, @code{file-accessible-directory-p}, -@code{file-attributes}, @code{file-directory-p}, -@code{file-executable-p}, @code{file-exists-p}, @code{file-local-copy}, -@code{file-modes}, @code{file-name-all-completions}, -@code{file-name-as-directory}, @code{file-name-completion}, -@code{file-name-directory}, @code{file-name-nondirectory}, -@code{file-name-sans-versions}, @code{file-newer-than-file-p}, -@code{file-readable-p}, @code{file-symlink-p}, @code{file-writable-p}, -@code{insert-directory}, @code{insert-file-contents}, -@code{make-directory}, @code{make-symbolic-link}, @code{rename-file}, -@code{set-file-modes}, @code{verify-visited-file-modtime}, -@code{write-region}. -@end quotation - -The handler function must handle all of the above operations, and -possibly others to be added in the future. Therefore, it should always -reinvoke the ordinary Lisp primitive when it receives an operation it -does not recognize. Here's one way to do this: - -@smallexample -(defun my-file-handler (primitive &rest args) - ;; @r{First check for the specific operations} - ;; @r{that we have special handling for.} - (cond ((eq operation 'insert-file-contents) @dots{}) - ((eq operation 'write-region) @dots{}) - @dots{} - ;; @r{Handle any operation we don't know about.} - (t (let (file-name-handler-alist) - (apply operation args))))) -@end smallexample - -The function @code{file-local-copy} copies file @var{filename} to the -local site, if it isn't there already. If @var{filename} specifies a -``magic'' file name which programs outside Emacs cannot directly read or -write, this copies the contents to an ordinary file and returns that -file's name. - -If @var{filename} is an ordinary file name, not magic, then this function -does nothing and returns @code{nil}. - -The function @code{unhandled-file-name-directory} is used to get a -non-magic directory name from an arbitrary file name. It uses the -directory part of the specified file name if that is not magic. -Otherwise, it asks the file name's handler what to do. - -@section Frames -@cindex frame - -Emacs now supports multiple X windows via a new data type known as a -@dfn{frame}. - -A frame is a rectangle on the screen that contains one or more Emacs -windows. Subdividing a frame works just like subdividing the screen in -earlier versions of Emacs. - -@cindex terminal frame -There are two kinds of frames: terminal frames and X window frames. -Emacs creates one terminal frame when it starts up with no X display; it -uses Termcap or Terminfo to display using characters. There is no way -to create another terminal frame after startup. If Emacs has an X -display, it does not make a terminal frame, and there is none. - -@cindex X window frame -When you are using X windows, Emacs starts out with a single X window -frame. You can create any number of X window frames using -@code{make-frame}. - -Use the predicate @code{framep} to determine whether a given Lisp object -is a frame. - -The function @code{redraw-frame} redisplays the entire contents of a -given frame. - -@subsection Creating and Deleting Frames - -Use @code{make-frame} to create a new frame (supported under X Windows -only). This is the only primitive for creating frames. - -@code{make-frame} takes just one argument, which is an alist -specifying frame parameters. Any parameters not mentioned in the -argument alist default based on the value of @code{default-frame-alist}; -parameters not specified there default from the standard X defaults file -and X resources. - -When you invoke Emacs, if you specify arguments for window appearance -and so forth, these go into @code{default-frame-alist} and that is how -they have their effect. - -You can specify the parameters for the initial startup X window frame by -setting @code{initial-frame-alist} in your @file{.emacs} file. If these -parameters specify a separate minibuffer-only frame, and you have not -created one, Emacs creates one for you, using the parameter values -specified in @code{minibuffer-frame-alist}. - -You can specify the size and position of a frame using the frame -parameters @code{left}, @code{top}, @code{height} and @code{width}. You -must specify either both size parameters or neither. You must specify -either both position parameters or neither. The geometry parameters -that you don't specify are chosen by the window manager in its usual -fashion. - -The function @code{x-parse-geometry} converts a standard X windows -geometry string to an alist which you can use as part of the argument to -@code{make-frame}. - -Use the function @code{delete-frame} to eliminate a frame. Frames are -like buffers where deletion is concerned; a frame actually continues to -exist as a Lisp object until it is deleted @emph{and} there are no -references to it, but once it is deleted, it has no further effect on -the screen. - -The function @code{frame-live-p} returns non-@code{nil} if the argument -(a frame) has not been deleted. - -@subsection Finding All Frames - -The function @code{frame-list} returns a list of all the frames that have -not been deleted. It is analogous to @code{buffer-list}. The list that -you get is newly created, so modifying the list doesn't have any effect -on the internals of Emacs. The function @code{visible-frame-list} returns -the list of just the frames that are visible. - -@code{next-frame} lets you cycle conveniently through all the frames from an -arbitrary starting point. Its first argument is a frame. Its second -argument @var{minibuf} says what to do about minibuffers: - -@table @asis -@item @code{nil} -Exclude minibuffer-only frames. -@item a window -Consider only the frames using that particular window as their -minibuffer. -@item anything else -Consider all frames. -@end table - -@subsection Frames and Windows - -All the non-minibuffer windows in a frame are arranged in a tree of -subdivisions; the root of this tree is available via the function -@code{frame-root-window}. Each window is part of one and only one -frame; you can get the frame with @code{window-frame}. - -At any time, exactly one window on any frame is @dfn{selected within the -frame}. You can get the frame's current selected window with -@code{frame-selected-window}. The significance of this designation is -that selecting the frame selects for Emacs as a whole the window -currently selected within that frame. - -Conversely, selecting a window for Emacs with @code{select-window} also -makes that window selected within its frame. - -@subsection Frame Visibility - -A frame may be @dfn{visible}, @dfn{invisible}, or @dfn{iconified}. If -it is invisible, it doesn't show in the screen, not even as an icon. -You can set the visibility status of a frame with -@code{make-frame-visible}, @code{make-frame-invisible}, and -@code{iconify-frame}. You can examine the visibility status with -@code{frame-visible-p}---it returns @code{t} for a visible frame, -@code{nil} for an invisible frame, and @code{icon} for an iconified -frame. - -@subsection Selected Frame - -At any time, one frame in Emacs is the @dfn{selected frame}. The selected -window always resides on the selected frame. - -@defun selected-frame -This function returns the selected frame. -@end defun - -The X server normally directs keyboard input to the X window that the -mouse is in. Some window managers use mouse clicks or keyboard events -to @dfn{shift the focus} to various X windows, overriding the normal -behavior of the server. - -Lisp programs can switch frames ``temporarily'' by calling the function -@code{select-frame}. This does not override the window manager; rather, -it escapes from the window manager's control until that control is -somehow reasserted. The function takes one argument, a frame, and -selects that frame. The selection lasts until the next time the user -does something to select a different frame, or until the next time this -function is called. - -Emacs cooperates with the X server and the window managers by arranging -to select frames according to what the server and window manager ask -for. It does so by generating a special kind of input event, called a -@dfn{focus} event. The command loop handles a focus event by calling -@code{internal-select-frame}. @xref{Focus Events}. - -@subsection Frame Size and Position - -The new functions @code{frame-height} and @code{frame-width} return the -height and width of a specified frame (or of the selected frame), -measured in characters. - -The new functions @code{frame-pixel-height} and @code{frame-pixel-width} -return the height and width of a specified frame (or of the selected -frame), measured in pixels. - -The new functions @code{frame-char-height} and @code{frame-char-width} -return the height and width of a character in a specified frame (or in -the selected frame), measured in pixels. - -@code{set-frame-size} sets the size of a frame, measured in characters; -its arguments are @var{frame}, @var{cols} and @var{rows}. To set the -size with values measured in pixels, you can use -@code{modify-frame-parameters}. - -The function @code{set-frame-position} sets the position of the top left -corner of a frame. Its arguments are @var{frame}, @var{left} and -@var{top}. - -@ignore -New functions @code{set-frame-height} and @code{set-frame-width} set the -size of a specified frame. The frame is the first argument; the size is -the second. -@end ignore - -@subsection Frame Parameters - -A frame has many parameters that affect how it displays. Use the -function @code{frame-parameters} to get an alist of all the parameters -of a given frame. To alter parameters, use -@code{modify-frame-parameters}, which takes two arguments: the frame to -modify, and an alist of parameters to change and their new values. Each -element of @var{alist} has the form @code{(@var{parm} . @var{value})}, -where @var{parm} is a symbol. Parameters that aren't meaningful are -ignored. If you don't mention a parameter in @var{alist}, its value -doesn't change. - -Just what parameters a frame has depends on what display mechanism it -uses. Here is a table of the parameters of an X -window frame: - -@table @code -@item name -The name of the frame. - -@item left -The screen position of the left edge. - -@item top -The screen position of the top edge. - -@item height -The height of the frame contents, in pixels. - -@item width -The width of the frame contents, in pixels. - -@item window-id -The number of the X window for the frame. - -@item minibuffer -Whether this frame has its own minibuffer. -@code{t} means yes, @code{none} means no, -@code{only} means this frame is just a minibuffer, -a minibuffer window (in some other frame) -means the new frame uses that minibuffer. - -@item font -The name of the font for the text. - -@item foreground-color -The color to use for the inside of a character. -Use strings to designate colors; -X windows defines the meaningful color names. - -@item background-color -The color to use for the background of text. - -@item mouse-color -The color for the mouse cursor. - -@item cursor-color -The color for the cursor that shows point. - -@item border-color -The color for the border of the frame. - -@item cursor-type -The way to display the cursor. There are two legitimate values: -@code{bar} and @code{box}. The value @code{bar} specifies a vertical -bar between characters as the cursor. The value @code{box} specifies an -ordinary black box overlaying the character after point; that is the -default. - -@item icon-type -Non-@code{nil} for a bitmap icon, @code{nil} for a text icon. - -@item border-width -The width in pixels of the window border. - -@item internal-border-width -The distance in pixels between text and border. - -@item auto-raise -Non-@code{nil} means selecting the frame raises it. - -@item auto-lower -Non-@code{nil} means deselecting the frame lowers it. - -@item vertical-scrollbar -Non-@code{nil} gives the frame a scroll bar -for vertical scrolling. - -@item horizontal-scrollbar -Non-@code{nil} gives the frame a scroll bar -for horizontal scrolling. -@end table - -@subsection Minibufferless Frames - -Normally, each frame has its own minibuffer window at the bottom, which -is used whenever that frame is selected. However, you can also create -frames with no minibuffers. These frames must use the minibuffer window -of some other frame. - -The variable @code{default-minibuffer-frame} specifies where to find a -minibuffer for frames created without minibuffers of their own. Its -value should be a frame which does have a minibuffer. - -You can also specify a minibuffer window explicitly when you create a -frame; then @code{default-minibuffer-frame} is not used. - -@section X Windows Features - -@itemize @bullet -@item -The new functions @code{mouse-position} and @code{set-mouse-position} give -access to the current position of the mouse. - -@code{mouse-position} returns a description of the position of the mouse. -The value looks like @code{(@var{frame} @var{x} . @var{y})}, where @var{x} -and @var{y} are measured in pixels relative to the top left corner of -the inside of @var{frame}. - -@code{set-mouse-position} takes three arguments, @var{frame}, @var{x} -and @var{y}, and warps the mouse cursor to that location on the screen. - -@item -@code{track-mouse} is a new special form for tracking mouse motion. -Use it in definitions of mouse clicks that want pay to attention to -the motion of the mouse, not just where the buttons are pressed and -released. Here is how to use it: - -@example -(track-mouse @var{body}@dots{}) -@end example - -While @var{body} executes, mouse motion generates input events just as mouse -clicks do. @var{body} can read them with @code{read-event} or -@code{read-key-sequence}. - -@code{track-mouse} returns the value of the last form in @var{body}. - -The format of these events is described under ``New features for key -bindings and input.'' -@c ??? - -@item -@code{x-set-selection} sets a ``selection'' in the X Windows server. -It takes two arguments: a selection type @var{type}, and the value to -assign to it, @var{data}. If @var{data} is @code{nil}, it means to -clear out the selection. Otherwise, @var{data} may be a string, a -symbol, an integer (or a cons of two integers or list of two integers), -or a cons of two markers pointing to the same buffer. In the last case, -the selection is considered to be the text between the markers. The -data may also be a vector of valid non-vector selection values. - -Each possible @var{type} has its own selection value, which changes -independently. The usual values of @var{type} are @code{PRIMARY} and -@code{SECONDARY}; these are symbols with upper-case names, in accord -with X Windows conventions. The default is @code{PRIMARY}. - -To get the value of the selection, call @code{x-get-selection}. This -function accesses selections set up by Emacs and those set up by other X -clients. It takes two optional arguments, @var{type} and -@var{data-type}. The default for @var{type} is @code{PRIMARY}. - -The @var{data-type} argument specifies the form of data conversion to -use; meaningful values include @code{TEXT}, @code{STRING}, -@code{TARGETS}, @code{LENGTH}, @code{DELETE}, @code{FILE_NAME}, -@code{CHARACTER_POSITION}, @code{LINE_NUMBER}, @code{COLUMN_NUMBER}, -@code{OWNER_OS}, @code{HOST_NAME}, @code{USER}, @code{CLASS}, -@code{NAME}, @code{ATOM}, and @code{INTEGER}. (These are symbols with -upper-case names in accord with X Windows conventions.) -The default for @var{data-type} is @code{STRING}. - -@item -X Windows has a set of numbered @dfn{cut buffers} which can store text -or other data being moved between applications. Use -@code{x-get-cut-buffer} to get the contents of a cut buffer; specify the -cut buffer number as argument. Use @code{x-set-cut-buffer} with -argument @var{string} to store a new string into the first cut buffer -(moving the other values down through the series of cut buffers, -kill-ring-style). - -Cut buffers are considered obsolete in X Windows, but Emacs supports -them for the sake of X clients that still use them. - -@item -You can close the connection with the X Windows server with -the function @code{x-close-current-connection}. This takes no arguments. - -Then you can connect to a different X Windows server with -@code{x-open-connection}. The first argument, @var{display}, is the -name of the display to connect to. - -The optional second argument @var{xrm-string} is a string of resource -names and values, in the same format used in the @file{.Xresources} -file. The values you specify override the resource values recorded in -the X Windows server itself. Here's an example of what this string -might look like: - -@example -"*BorderWidth: 3\n*InternalBorder: 2\n" -@end example - -@item -A series of new functions give you information about the X server and -the screen you are using. - -@table @code -@item x-display-screens -The number of screens associated with the current display. - -@item x-server-version -The version numbers of the X server in use. - -@item x-server-vendor -The vendor supporting the X server in use. - -@item x-display-pixel-height -The height of this X screen in pixels. - -@item x-display-mm-height -The height of this X screen in millimeters. - -@item x-display-pixel-width -The width of this X screen in pixels. - -@item x-display-mm-width -The width of this X screen in millimeters. - -@item x-display-backing-store -The backing store capability of this screen. Values can be the symbols -@code{always}, @code{when-mapped}, or @code{not-useful}. - -@item x-display-save-under -Non-@code{nil} if this X screen supports the SaveUnder feature. - -@item x-display-planes -The number of planes this display supports. - -@item x-display-visual-class -The visual class for this X screen. The value is one of the symbols -@code{static-gray}, @code{gray-scale}, @code{static-color}, -@code{pseudo-color}, @code{true-color}, and @code{direct-color}. - -@item x-display-color-p -@code{t} if the X screen in use is a color screen. - -@item x-display-color-cells -The number of color cells this X screen supports. -@end table - -There is also a variable @code{x-no-window-manager}, whose value is -@code{t} if no X window manager is in use. - -@item -The function @code{x-synchronize} enables or disables an X Windows -debugging mode: synchronous communication. It takes one argument, -non-@code{nil} to enable the mode and @code{nil} to disable. - -In synchronous mode, Emacs waits for a response to each X protocol -command before doing anything else. This means that errors are reported -right away, and you can directly find the erroneous command. -Synchronous mode is not the default because it is much slower. - -@item -The function @code{x-get-resource} retrieves a resource value from the X -Windows defaults database. Its three arguments are @var{attribute}, -@var{name} and @var{class}. It searches using a key of the form -@samp{@var{instance}.@var{attribute}}, with class @samp{Emacs}, where -@var{instance} is the name under which Emacs was invoked. - -The optional arguments @var{component} and @var{subclass} add to the key -and the class, respectively. You must specify both of them or neither. -If you specify them, the key is -@samp{@var{instance}.@var{component}.@var{attribute}}, and the class is -@samp{Emacs.@var{subclass}}. - -@item -@code{x-color-display-p} returns @code{t} if you are using an X Window -server with a color display, and @code{nil} otherwise. - -@c ??? Name being changed from x-defined-color. -@code{x-color-defined-p} takes as argument a string describing a color; it -returns @code{t} if the display supports that color. (If the color is -@code{"black"} or @code{"white"} then even black-and-white displays -support it.) - -@item -@code{x-popup-menu} has been generalized. It now accepts a keymap as -the @var{menu} argument. Then the menu items are the prompt strings of -individual key bindings, and the item values are the keys which have -those bindings. - -You can also supply a list of keymaps as the first argument; then each -keymap makes one menu pane (but keymaps that don't provide any menu -items don't appear in the menu at all). - -@code{x-popup-menu} also accepts a mouse button event as the -@var{position} argument. Then it displays the menu at the location at -which the event took place. This is convenient for mouse-invoked -commands that pop up menus. - -@ignore -@item -x-pointer-shape, x-nontext-pointer-shape, x-mode-pointer-shape. -@end ignore - -@item -You can use the function @code{x-rebind-key} to change the sequence -of characters generated by one of the keyboard keys. This works -only with X Windows. - -The first two arguments, @var{keycode} and @var{shift-mask}, should be -numbers representing the keyboard code and shift mask respectively. -They specify what key to change. - -The third argument, @var{newstring}, is the new definition of the key. -It is a sequence of characters that the key should produce as input. - -The shift mask value is a combination of bits according to this table: - -@table @asis -@item 8 -Control -@item 4 -Meta -@item 2 -Shift -@item 1 -Shift Lock -@end table - -If you specify @code{nil} for @var{shift-mask}, then the key specified -by @var{keycode} is redefined for all possible shift combinations. - -For the possible values of @var{keycode} and their meanings, see the -file @file{/usr/lib/Xkeymap.txt}. Keep in mind that the codes in that -file are in octal! - -@ignore @c Presumably this is already fixed -NOTE: due to an X bug, this function will not take effect unless the -user has a @file{~/.Xkeymap} file. (See the documentation for the -@code{keycomp} program.) This problem will be fixed in X version 11. -@end ignore - -The related function @code{x-rebind-keys} redefines a single keyboard -key, specifying the behavior for each of the 16 shift masks -independently. The first argument is @var{keycode}, as in -@code{x-rebind-key}. The second argument @var{strings} is a list of 16 -elements, one for each possible shift mask value; each element says how -to redefine the key @var{keycode} with the corresponding shift mask -value. If an element is a string, it is the new definition. If an -element is @code{nil}, the definition does not change for that shift -mask. - -@item -The function @code{x-geometry} parses a string specifying window size -and position in the usual fashion for X windows. It returns an alist -describing which parameters were specified, and the values that were -given for them. - -The elements of the alist look like @code{(@var{parameter} . -@var{value})}. The possible @var{parameter} values are @code{left}, -@code{top}, @code{width}, and @code{height}. -@end itemize - -@section New Window Features - -@itemize @bullet -@item -The new function @code{window-at} tells you which window contains a -given horizontal and vertical position on a specified frame. Call it -with three arguments, like this: - -@example -(window-at @var{x} @var{column} @var{frame}) -@end example - -The function returns the window which contains that cursor position in -the frame @var{frame}. If you omit @var{frame}, the selected frame is -used. - -@item -The function @code{coordinates-in-window-p} takes two arguments and -checks whether a particular frame position falls within a particular -window. - -@example -(coordinates-in-window-p @var{coordinates} @var{window}) -@end example - -The argument @var{coordinates} is a cons cell of this form: - -@example -(@var{x} . @var{y}) -@end example - -@noindent -The two coordinates are measured in characters, and count from the top -left corner of the screen or frame. - -The value of the function tells you what part of the window the position -is in. The possible values are: - -@table @code -@item (@var{relx} . @var{rely}) -The coordinates are inside @var{window}. The numbers @var{relx} and -@var{rely} are equivalent window-relative coordinates, counting from 0 -at the top left corner of the window. - -@item mode-line -The coordinates are in the mode line of @var{window}. - -@item vertical-split -The coordinates are in the vertical line between @var{window} and its -neighbor to the right. - -@item nil -The coordinates are not in any sense within @var{window}. -@end table - -You need not specify a frame when you call -@code{coordinates-in-window-p}, because it assumes you mean the frame -which window @var{window} is on. - -@item -The function @code{minibuffer-window} now accepts a frame as argument -and returns the minibuffer window used for that frame. If you don't -specify a frame, the currently selected frame is used. The minibuffer -window may be on the frame in question, but if that frame has no -minibuffer of its own, it uses the minibuffer window of some other -frame, and @code{minibuffer-window} returns that window. - -@item -Use @code{window-live-p} to test whether a window is still alive (that -is, not deleted). - -@item -Use @code{window-minibuffer-p} to determine whether a given window is a -minibuffer or not. It no longer works to do this by comparing the -window with the result of @code{(minibuffer-window)}, because there can -be more than one minibuffer window at a time (if you have multiple -frames). - -@item -If you set the variable @code{pop-up-frames} non-@code{nil}, then the -functions to show something ``in another window'' actually create a new -frame for the new window. Thus, you will tend to have a frame for each -window, and you can easily have a frame for each buffer. - -The value of the variable @code{pop-up-frame-function} controls how new -frames are made. The value should be a function which takes no -arguments and returns a frame. The default value is a function which -creates a frame using parameters from @code{pop-up-frame-alist}. - -@item -@code{display-buffer} is the basic primitive for finding a way to show a -buffer on the screen. You can customize its behavior by storing a -function in the variable @code{display-buffer-function}. If this -variable is non-@code{nil}, then @code{display-buffer} calls it to do -the work. Your function should accept two arguments, as follows: - -@table @var -@item buffer -The buffer to be displayed. - -@item flag -A flag which, if non-@code{nil}, means you should find another window to -display @var{buffer} in, even if it is already visible in the selected -window. -@end table - -The function you supply will be used by commands such as -@code{switch-to-buffer-other-window} and @code{find-file-other-window} -as well as for your own calls to @code{display-buffer}. - -@item -@code{delete-window} now gives all of the deleted window's screen space -to a single neighboring window. Likewise, @code{enlarge-window} takes -space from only one neighboring window until that window disappears; -only then does it take from another window. - -@item -@code{next-window} and @code{previous-window} accept another argument, -@var{all-frames}. - -These functions now take three optional arguments: @var{window}, -@var{minibuf} and @var{all-frames}. @var{window} is the window to start -from (@code{nil} means use the selected window). @var{minibuf} says -whether to include the minibuffer in the windows to cycle through: -@code{t} means yes, @code{nil} means yes if it is active, and anything -else means no. - -Normally, these functions cycle through all the windows in the -selected frame, plus the minibuffer used by the selected frame even if -it lies in some other frame. - -If @var{all-frames} is @code{t}, then these functions cycle through -all the windows in all the frames that currently exist. If -@var{all-frames} is neither @code{t} nor @code{nil}, then they limit -themselves strictly to the windows in the selected frame, excluding the -minibuffer in use if it lies in some other frame. - -@item -The functions @code{get-lru-window} and @code{get-largest-window} now -take an optional argument @var{all-frames}. If it is non-@code{nil}, -the functions consider all windows on all frames. Otherwise, they -consider just the windows on the selected frame. - -Likewise, @code{get-buffer-window} takes an optional second argument -@var{all-frames}. - -@item -The variable @code{other-window-scroll-buffer} specifies which buffer -@code{scroll-other-window} should scroll. - -@item -You can now mark a window as ``dedicated'' to its buffer. -Then Emacs will not try to use that window for any other buffer -unless you explicitly request it. - -Use the new function @code{set-window-dedicated-p} to set the dedication -flag of a window @var{window} to the value @var{flag}. If @var{flag} is -@code{t}, this makes the window dedicated. If @var{flag} is -@code{nil}, this makes the window non-dedicated. - -Use @code{window-dedicated-p} to examine the dedication flag of a -specified window. - -@item -The new function @code{walk-windows} cycles through all visible -windows, calling @code{proc} once for each window with the window as -its sole argument. - -The optional second argument @var{minibuf} says whether to include minibuffer -windows. A value of @code{t} means count the minibuffer window even if -not active. A value of @code{nil} means count it only if active. Any -other value means not to count the minibuffer even if it is active. - -If the optional third argument @var{all-frames} is @code{t}, that means -include all windows in all frames. If @var{all-frames} is @code{nil}, -it means to cycle within the selected frame, but include the minibuffer -window (if @var{minibuf} says so) that that frame uses, even if it is on -another frame. If @var{all-frames} is neither @code{nil} nor @code{t}, -@code{walk-windows} sticks strictly to the selected frame. - -@item -The function @code{window-end} is a counterpart to @code{window-start}: -it returns the buffer position of the end of the display in a given -window (or the selected window). - -@item -The function @code{window-configuration-p} returns non-@code{nil} when -given an object that is a window configuration (such as is returned by -@code{current-window-configuration}). -@end itemize - -@section Display Features - -@itemize @bullet -@item -@samp{%l} as a mode line item displays the current line number. - -If the buffer is longer than @code{line-number-display-limit} -characters, or if lines are too long in the viscinity of the current -displayed text, then line number display is inhibited to save time. - -The default contents of the mode line include the line number if -@code{line-number-mode} is non-@code{nil}. - -@item -@code{baud-rate} is now a variable rather than a function. This is so -you can set it to reflect the effective speed of your terminal, when the -system doesn't accurately know the speed. - -@item -You can now remove any echo area message and make the minibuffer -visible. To do this, call @code{message} with @code{nil} as the only -argument. This clears any existing message, and lets the current -minibuffer contents show through. Previously, there was no reliable way -to make sure that the minibuffer contents were visible. - -@item -The variable @code{temp-buffer-show-hook} has been renamed -@code{temp-buffer-show-function}, because its value is a single function -(of one argument), not a normal hook. - -@item -The new function @code{force-mode-line-update} causes redisplay -of the current buffer's mode line. -@end itemize - -@section Display Tables - -@cindex display table -You can use the @dfn{display table} feature to control how all 256 -possible character codes display on the screen. This is useful for -displaying European languages that have letters not in the ASCII -character set. - -The display table maps each character code into a sequence of -@dfn{glyphs}, each glyph being an image that takes up one character -position on the screen. You can also define how to display each glyph -on your terminal, using the @dfn{glyph table}. - -@subsection Display Tables - -Use @code{make-display-table} to create a display table. The table -initially has @code{nil} in all elements. - -A display table is actually an array of 261 elements. The first 256 -elements of a display table control how to display each possible text -character. The value should be @code{nil} or a vector (which is a -sequence of glyphs; see below). @code{nil} as an element means to -display that character following the usual display conventions. - -The remaining five elements of a display table serve special purposes -(@code{nil} means use the default stated below): - -@table @asis -@item 256 -The glyph for the end of a truncated screen line (the default for this -is @samp{\}). -@item 257 -The glyph for the end of a continued line (the default is @samp{$}). -@item 258 -The glyph for the indicating an octal character code (the default is -@samp{\}). -@item 259 -The glyph for indicating a control characters (the default is @samp{^}). -@item 260 -The vector of glyphs for indicating the presence of invisible lines (the -default is @samp{...}). -@end table - -Each buffer typically has its own display table. The display table for -the current buffer is stored in @code{buffer-display-table}. (This -variable automatically becomes local if you set it.) If this variable -is @code{nil}, the value of @code{standard-display-table} is used in -that buffer. - -Each window can have its own display table, which overrides the display -table of the buffer it is showing. - -If neither the selected window nor the current buffer has a display -table, and if @code{standard-display-table} is @code{nil}, then Emacs -uses the usual display conventions: - -@itemize @bullet -@item -Character codes 32 through 127 map to glyph codes 32 through 127. -@item -Codes 0 through 31 map to sequences of two glyphs, where the first glyph -is the ASCII code for @samp{^}. -@item -Character codes 128 through 255 map to sequences of four glyphs, where -the first glyph is the ASCII code for @samp{\}, and the others represent -digits. -@end itemize - -The usual display conventions are also used for any character whose -entry in the active display table is @code{nil}. This means that when -you set up a display table, you need not specify explicitly what to do -with each character, only the characters for which you want unusual -behavior. - -@subsection Glyphs - -@cindex glyph -A glyph stands for an image that takes up a single character position on -the screen. A glyph is represented in Lisp as an integer. - -@cindex glyph table -The meaning of each integer, as a glyph, is defined by the glyph table, -which is the value of the variable @code{glyph-table}. It should be a -vector; the @var{g}th element defines glyph code @var{g}. The possible -definitions of a glyph code are: - -@table @var -@item integer -Define this glyph code as an alias for code @var{integer}. -This is used with X windows to specify a face code. - -@item string -Send the characters in @var{string} to the terminal to output -this glyph. This alternative is not available with X Windows. - -@item @code{nil} -This glyph is simple. On an ordinary terminal, the glyph code mod 256 -is the character to output. With X, the glyph code mod 256 is character -to output, and the glyph code divided by 256 specifies the @dfn{face -code} to use while outputting it. -@end table - -Any glyph code beyond the length of the glyph table is automatically simple. - -A face code for X windows is the combination of a font and a color. -Emacs uses integers to identify face codes. You can define a new face -code with @code{(x-set-face @var{face-code} @var{font} @var{foreground} -@var{background})}. @var{face-code} is an integer from 0 to 255; it -specifies which face to define. The other three arguments are strings: -@var{font} is the name of the font to use, and @var{foreground} and -@var{background} specify the colors to use. - -If @code{glyph-table} is @code{nil}, then all possible glyph codes are -simple. - -@subsection ISO Latin 1 - -If you have a terminal that can handle the entire ISO Latin 1 character -set, you can arrange to use that character set as follows: - -@example -(require 'disp-table) -(standard-display-8bit 0 255) -@end example - -If you are editing buffers written in the ISO Latin 1 character set and -your terminal doesn't handle anything but ASCII, you can load the file -@code{iso-ascii} to set up a display table which makes the other ISO -characters display as sequences of ASCII characters. For example, the -character ``o with umlaut'' displays as @samp{@{"o@}}. - -Some European countries have terminals that don't support ISO Latin 1 -but do support the special characters for that country's language. You -can define a display table to work one language using such terminals. -For an example, see @file{lisp/iso-swed.el}, which handles certain -Swedish terminals. - -You can load the appropriate display table for your terminal -automatically by writing a terminal-specific Lisp file for the terminal -type. - -@section New Input Event Formats - -Mouse clicks, mouse movements and function keys no longer appear in the -input stream as characters; instead, other kinds of Lisp objects -represent them as input. - -@itemize @bullet -@item -An ordinary input character event consists of a @dfn{basic code} between -0 and 255, plus any or all of these @dfn{modifier bits}: - -@table @asis -@item meta -The 2**23 bit in the character code indicates a character -typed with the meta key held down. - -@item control -The 2**22 bit in the character code indicates a non-@sc{ASCII} -control character. - -@sc{ASCII} control characters such as @kbd{C-a} have special basic -codes of their own, so Emacs needs no special bit to indicate them. -Thus, the code for @kbd{C-a} is just 1. - -But if you type a control combination not in @sc{ASCII}, such as -@kbd{%} with the control key, the numeric value you get is the code -for @kbd{%} plus 2**22 (assuming the terminal supports non-@sc{ASCII} -control characters). - -@item shift -The 2**21 bit in the character code indicates an @sc{ASCII} control -character typed with the shift key held down. - -For letters, the basic code indicates upper versus lower case; for -digits and punctuation, the shift key selects an entirely different -character with a different basic code. In order to keep within -the @sc{ASCII} character set whenever possible, Emacs avoids using -the 2**21 bit for those characters. - -However, @sc{ASCII} provides no way to distinguish @kbd{C-A} from -@kbd{C-A}, so Emacs uses the 2**21 bit in @kbd{C-A} and not in -@kbd{C-a}. - -@item hyper -The 2**20 bit in the character code indicates a character -typed with the hyper key held down. - -@item super -The 2**19 bit in the character code indicates a character -typed with the super key held down. - -@item alt -The 2**18 bit in the character code indicates a character typed with -the alt key held down. (On some terminals, the key labeled @key{ALT} -is actually the meta key.) -@end table - -In the future, Emacs may support a larger range of basic codes. We may -also move the modifier bits to larger bit numbers. Therefore, you -should avoid mentioning specific bit numbers in your program. Instead, -the way to test the modifier bits of a character is with the function -@code{event-modifiers} (see below). - -@item -Function keys are represented as symbols. The symbol's name is -the function key's label. For example, pressing a key labeled @key{F1} -places the symbol @code{f1} in the input stream. - -There are a few exceptions to the symbol naming convention: - -@table @asis -@item @code{kp-add}, @code{kp-decimal}, @code{kp-divide}, @dots{} -Keypad keys (to the right of the regular keyboard). -@item @code{kp-0}, @code{kp-1}, @dots{} -Keypad keys with digits. -@item @code{kp-f1}, @code{kp-f2}, @code{kp-f3}, @code{kp-f4} -Keypad PF keys. -@item @code{left}, @code{up}, @code{right}, @code{down} -Cursor arrow keys -@end table - -You can use the modifier keys @key{CTRL}, @key{META}, @key{HYPER}, -@key{SUPER}, @key{ALT} and @key{SHIFT} with function keys. The way -to represent them is with prefixes in the symbol name: - -@table @samp -@item A- -The alt modifier. -@item C- -The control modifier. -@item H- -The hyper modifier. -@item M- -The meta modifier. -@item s- -The super modifier. -@item S- -The shift modifier. -@end table - -Thus, the symbol for the key @key{F3} with @key{META} held down is -kbd{M-@key{F3}}. When you use more than one prefix, we recommend you -write them in alphabetical order (though the order does not matter in -arguments to the key-binding lookup and modification functions). - -@item -Mouse events are represented as lists. - -If you press a mouse button and release it at the same location, this -generates a ``click'' event. Mouse click events have this form: - -@example -(@var{button-symbol} - (@var{window} (@var{column} . @var{row}) - @var{buffer-pos} @var{timestamp})) -@end example - -Here is what the elements normally mean: - -@table @var -@item button-symbol -indicates which mouse button was used. It is one of the symbols -@code{mouse-1}, @code{mouse-2}, @dots{}, where the buttons are numbered -numbered left to right. - -You can also use prefixes @samp{A-}, @samp{C-}, @samp{H-}, @samp{M-}, -@samp{S-} and @samp{s-} for modifiers alt, control, hyper, meta, shift -and super, just as you would with function keys. - -@item window -is the window in which the click occurred. - -@item column -@itemx row -are the column and row of the click, relative to the top left corner of -@var{window}, which is @code{(0 . 0)}. - -@item buffer-pos -is the buffer position of the character clicked on. - -@item timestamp -is the time at which the event occurred, in milliseconds. (Since this -value wraps around the entire range of Emacs Lisp integers in about five -hours, it is useful only for relating the times of nearby events.) -@end table - -The meanings of @var{buffer-pos}, @var{row} and @var{column} are -somewhat different when the event location is in a special part of the -screen, such as the mode line or a scroll bar. - -If the position is in the window's scroll bar, then @var{buffer-pos} is -the symbol @code{vertical-scrollbar} or @code{horizontal-scrollbar}, and -the pair @code{(@var{column} . @var{row})} is instead a pair -@code{(@var{portion} . @var{whole})}, where @var{portion} is the -distance of the click from the top or left end of the scroll bar, and -@var{whole} is the length of the entire scroll bar. - -If the position is on a mode line or the vertical line separating -@var{window} from its neighbor to the right, then @var{buffer-pos} is -the symbol @code{mode-line} or @code{vertical-line}. In this case -@var{row} and @var{column} do not have meaningful data. - -@item -Releasing a mouse button above a different character position -generates a ``drag'' event, which looks like this: - -@example -(@var{button-symbol} - (@var{window1} (@var{column1} . @var{row1}) - @var{buffer-pos1} @var{timestamp1}) - (@var{window2} (@var{column2} . @var{row2}) - @var{buffer-pos2} @var{timestamp2})) -@end example - -The name of @var{button-symbol} contains the prefix @samp{drag-}. The -second and third elements of the event give the starting and ending -position of the drag. - -The @samp{drag-} prefix follows the modifier key prefixes such as -@samp{C-} and @samp{M-}. - -If @code{read-key-sequence} receives a drag event which has no key -binding, and the corresponding click event does have a binding, it -changes the drag event into a click event at the drag's starting -position. This means that you don't have to distinguish between click -and drag events unless you want to. - -@item -Click and drag events happen when you release a mouse button. Another -kind of event happens when you press a button. It looks just like a -click event, except that the name of @var{button-symbol} contains the -prefix @samp{down-}. The @samp{down-} prefix follows the modifier key -prefixes such as @samp{C-} and @samp{M-}. - -The function @code{read-key-sequence}, and the Emacs command loop, -ignore any down events that don't have command bindings. This means -that you need not worry about defining down events unless you want them -to do something. The usual reason to define a down event is so that you -can track mouse motion until the button is released. - -@item -For example, if the user presses and releases the left mouse button over -the same location, Emacs generates a sequence of events like this: - -@smallexample -(down-mouse-1 (#<window 18 on NEWS> 2613 (0 . 38) -864320)) -(mouse-1 (#<window 18 on NEWS> 2613 (0 . 38) -864180)) -@end smallexample - -Or, while holding the control key down, the user might hold down the -second mouse button, and drag the mouse from one line to the next. -That produces two events, as shown here: - -@smallexample -(C-down-mouse-2 (#<window 18 on NEWS> 3440 (0 . 27) -731219)) -(C-drag-mouse-2 (#<window 18 on NEWS> 3440 (0 . 27) -731219) - (#<window 18 on NEWS> 3510 (0 . 28) -729648)) -@end smallexample - -Or, while holding down the meta and shift keys, the user might press -the second mouse button on the window's mode line, and then drag the -mouse into another window. That produces an event like this: - -@smallexample -(M-S-down-mouse-2 (#<window 18 on NEWS> mode-line (33 . 31) -457844)) -(M-S-drag-mouse-2 (#<window 18 on NEWS> mode-line (33 . 31) -457844) - (#<window 20 on carlton-sanskrit.tex> 161 (33 . 3) - -453816)) -@end smallexample - -@item -A key sequence that starts with a mouse click is read using the keymaps -of the buffer in the window clicked on, not the current buffer. - -This does not imply that clicking in a window selects that window or its -buffer. The execution of the command begins with no change in the -selected window or current buffer. However, the command can switch -windows or buffers if programmed to do so. - -@item -Mouse motion events are represented by lists. During the execution of -the body of a @code{track-mouse} form, moving the mouse generates events -that look like this: - -@example -(mouse-movement (@var{window} (@var{column} . @var{row}) - @var{buffer-pos} @var{timestamp})) -@end example - -The second element of the list describes the current position of the -mouse, just as in a mouse click event. - -Outside of @code{track-mouse} forms, Emacs does not generate events for -mere motion of the mouse, and these events do not appear. - -@item -Focus shifts between frames are represented by lists. - -When the mouse shifts temporary input focus from one frame to another, -Emacs generates an event like this: - -@example -(switch-frame @var{new-frame}) -@end example - -@noindent -where @var{new-frame} is the frame switched to. - -In X windows, most window managers are set up so that just moving the -mouse into a window is enough to set the focus there. As far as the -user concern, Emacs behaves consistently with this. However, there is -no need for the Lisp program to know about the focus change until some -other kind of input arrives. So Emacs generates the focus event only -when the user actually types a keyboard key or presses a mouse button in -the new frame; just moving the mouse between frames does not generate a -focus event. - -The global key map usually binds this event to the -@code{internal-select-frame} function, so that characters typed at a -frame apply to that frame's selected window. - -If the user switches frames in the middle of a key sequence, then Emacs -delays the @code{switch-frame} event until the key sequence is over. -For example, suppose @kbd{C-c C-a} is a key sequence in the current -buffer's keymaps. If the user types @kbd{C-c}, moves the mouse to -another frame, and then types @kbd{C-a}, @code{read-key-sequence} -returns the sequence @code{"\C-c\C-a"}, and the next call to -@code{read-event} or @code{read-key-sequence} will return the -@code{switch-frame} event. -@end itemize - -@section Working with Input Events - -@itemize @bullet -@item -Functions which work with key sequences now handle non-character -events. Functions like @code{define-key}, @code{global-set-key}, and -@code{local-set-key} used to accept strings representing key sequences; -now, since events may be arbitrary lisp objects, they also accept -vectors. The function @code{read-key-sequence} may return a string or a -vector, depending on whether or not the sequence read contains only -characters. - -List events may be represented by the symbols at their head; to bind -clicks of the left mouse button, you need only present the symbol -@code{mouse-1}, not an entire mouse click event. If you do put an event -which is a list in a key sequence, only the event's head symbol is used -in key lookups. - -For example, to globally bind the left mouse button to the function -@code{mouse-set-point}, you could evaluate this: - -@example -(global-set-key [mouse-1] 'mouse-set-point) -@end example - -To bind the sequence @kbd{C-c @key{F1}} to the command @code{tex-view} -in @code{tex-mode-map}, you could evaluate this: - -@example -(define-key tex-mode-map [?\C-c f1] 'tex-view) -@end example - -To find the binding for the function key labeled @key{NEXT} in -@code{minibuffer-local-map}, you could evaluate this: - -@example -(lookup-key minibuffer-local-map [next]) - @result{} next-history-element -@end example - -If you call the function @code{read-key-sequence} and then press -@kbd{C-x C-@key{F5}}, here is how it behaves: - -@example -(read-key-sequence "Press `C-x C-F5': ") - @result{} [24 C-f5] -@end example - -Note that @samp{24} is the character @kbd{C-x}. - -@item -The documentation functions (@code{single-key-description}, -@code{key-description}, etc.) now handle the new event types. Wherever -a string of keyboard input characters was acceptable in previous -versions of Emacs, a vector of events should now work. - -@item -Special parts of a window can have their own bindings for mouse events. - -When mouse events occur in special parts of a window, such as a mode -line or a scroll bar, the event itself shows nothing special---only the -symbol that would normally represent that mouse button and modifier -keys. The information about the screen region is kept in other parts -of the event list. But @code{read-key-sequence} translates this -information into imaginary prefix keys, all of which are symbols: -@code{mode-line}, @code{vertical-line}, @code{horizontal-scrollbar} and -@code{vertical-scrollbar}. - -For example, if you call @code{read-key-sequence} and then click the -mouse on the window's mode line, this is what happens: - -@smallexample -(read-key-sequence "Click on the mode line: ") - @result{} [mode-line (mouse-1 (#<window 6 on NEWS> mode-line - (40 . 63) 5959987))] -@end smallexample - -You can define meanings for mouse clicks in special window regions by -defining key sequences using these imaginary prefix keys. For example, -here is how to bind the third mouse button on a window's mode line -delete the window: - -@example -(global-set-key [mode-line mouse-3] 'mouse-delete-window) -@end example - -Here's how to bind the middle button (modified by @key{META}) on the -vertical line at the right of a window to scroll the window to the -left. - -@example -(global-set-key [vertical-line M-mouse-2] 'scroll-left) -@end example - -@item -Decomposing an event symbol. - -Each symbol used to identify a function key or mouse button has a -property named @code{event-symbol-elements}, which is a list containing -an unmodified version of the symbol, followed by modifiers the symbol -name contains. The modifiers are symbols; they include @code{shift}, -@code{control}, and @code{meta}. In addition, a mouse event symbol has -one of @code{click}, @code{drag}, and @code{down}. For example: - -@example -(get 'f5 'event-symbol-elements) - @result{} (f5) -(get 'C-f5 'event-symbol-elements) - @result{} (f5 control) -(get 'M-S-f5 'event-symbol-elements) - @result{} (f5 meta shift) -(get 'mouse-1 'event-symbol-elements) - @result{} (mouse-1 click) -(get 'down-mouse-1 'event-symbol-elements) - @result{} (mouse-1 down) -@end example - -Note that the @code{event-symbol-elements} property for a mouse click -explicitly contains @code{click}, but the event symbol name itself does -not contain @samp{click}. - -@item -Use @code{read-event} to read input if you want to accept any kind of -event. The old function @code{read-char} now discards events other than -keyboard characters. - -@item -@code{last-command-char} and @code{last-input-char} can now hold any -kind of event. - -@item -The new variable @code{unread-command-events} is much like -@code{unread-command-char}. Its value is a list of events of any type, -to be processed as command input in order of appearance in the list. - -@item -The function @code{this-command-keys} may return a string or a vector, -depending on whether or not the sequence read contains only characters. -You may need to upgrade code which uses this function. - -The function @code{recent-keys} now returns a vector of events. -You may need to upgrade code which uses this function. - -@item -A keyboard macro's definition can now be either a string or a vector. -All that really matters is what elements it has. If the elements are -all characters, then the macro can be a string; otherwise, it has to be -a vector. - -@item -The variable @code{last-event-frame} records which frame the last input -event was directed to. Usually this is the frame that was selected when -the event was generated, but if that frame has redirected input focus to -another frame, @code{last-event-frame} is the frame to which the event -was redirected. - -@item -The interactive specification now allows a new code letter @samp{e} to -simplify commands bound to events which are lists. This code supplies -as an argument the complete event object. - -You can use @samp{e} more than once in a single command's interactive -specification. If the key sequence which invoked the command has -@var{n} events with parameters, the @var{n}th @samp{e} provides the -@var{n}th parameterized event. Events which are not lists, such as -function keys and ASCII keystrokes, do not count where @samp{e} is -concerned. - -@item -You can extract the starting and ending position values from a mouse -button or motion event using the two functions @code{event-start} and -@code{event-end}. These two functions return different values for drag -and motion events; for click and button-down events, they both return -the position of the event. - -@item -The position, a returned by @code{event-start} and @code{event-end}, is -a list of this form: - -@example -(@var{window} @var{buffer-position} (@var{col} . @var{row}) @var{timestamp}) -@end example - -You can extract parts of this list with the functions -@code{posn-window}, @code{posn-point}, @code{posn-col-row}, and -@code{posn-timestamp}. - -@item -The function @code{scroll-bar-scale} is useful for computing where to -scroll to in response to a mouse button event from a scroll bar. It -takes two arguments, @var{ratio} and @var{total}, and in effect -multiplies them. We say ``in effect'' because @var{ratio} is not a -number; rather a pair @code{(@var{num} . @var{denom}). - -Here's the usual way to use @code{scroll-bar-scale}: - -@example -(scroll-bar-scale (posn-col-row (event-start event)) - (buffer-size)) -@end example -@end itemize - -@section Putting Keyboard Events in Strings - - In most of the places where strings are used, we conceptualize the -string as containing text characters---the same kind of characters found -in buffers or files. Occasionally Lisp programs use strings which -conceptually contain keyboard characters; for example, they may be key -sequences or keyboard macro definitions. There are special rules for -how to put keyboard characters into a string, because they are not -limited to the range of 0 to 255 as text characters are. - - A keyboard character typed using the @key{META} key is called a -@dfn{meta character}. The numeric code for such an event includes the -2**23 bit; it does not even come close to fitting in a string. However, -earlier Emacs versions used a different representation for these -characters, which gave them codes in the range of 128 to 255. That did -fit in a string, and many Lisp programs contain string constants that -use @samp{\M-} to express meta characters, especially as the argument to -@code{define-key} and similar functions. - - We provide backward compatibility to run those programs with special -rules for how to put a keyboard character event in a string. Here are -the rules: - -@itemize @bullet -@item -If the keyboard event value is in the range of 0 to 127, it can go in the -string unchanged. - -@item -The meta variants of those events, with codes in the range of 2**23 to -2**23+127, can also go in the string, but you must change their numeric -values. You must set the 2**7 bit instead of the 2**23 bit, resulting -in a value between 128 and 255. - -@item -Other keyboard character events cannot fit in a string. This includes -keyboard events in the range of 128 to 255. -@end itemize - - Functions such as @code{read-key-sequence} that can construct strings -containing events follow these rules. - - When you use the read syntax @samp{\M-} in a string, it produces a -code in the range of 128 to 255---the same code that you get if you -modify the corresponding keyboard event to put it in the string. Thus, -meta events in strings work consistently regardless of how they get into -the strings. - - New programs can avoid dealing with these rules by using vectors -instead of strings for key sequences when there is any possibility that -these issues might arise. - - The reason we changed the representation of meta characters as -keyboard events is to make room for basic character codes beyond 127, -and support meta variants of such larger character codes. - -@section Menus - -You can now define menus conveniently as keymaps. Menus are normally -used with the mouse, but they can work with the keyboard also. - -@subsection Defining Menus - -A keymap is suitable for menu use if it has an @dfn{overall prompt -string}, which is a string that appears as an element of the keymap. It -should describes the purpose of the menu. The easiest way to construct -a keymap with a prompt string is to specify the string as an argument -when you run @code{make-keymap} or @code{make-sparse-keymap}. - -The individual bindings in the menu keymap should also have prompt -strings; these strings are the items in the menu. A binding with a -prompt string looks like this: - -@example -(@var{char} @var{string} . @var{real-binding}) -@end example - -As far as @code{define-key} is concerned, the string is part of the -character's binding---the binding looks like this: - -@example -(@var{string} . @var{real-binding}). -@end example - -However, only @var{real-binding} is used for executing the key. - -You can also supply a second string, called the help string, as follows: - -@example -(@var{char} @var{string} @var{help-string} . @var{real-binding}) -@end example - -Currently Emacs does not actually use @var{help-string}; it knows only -how to ignore @var{help-string} in order to extract @var{real-binding}. -In the future we hope to make @var{help-string} serve as longer -documentation for the menu item, available on request. - -The prompt string for a binding should be short---one or two words. Its -meaning should describe the command it corresponds to. - -If @var{real-binding} is @code{nil}, then @var{string} appears in the -menu but cannot be selected. - -If @var{real-binding} is a symbol, and has a non-@code{nil} -@code{menu-enable} property, that property is an expression which -controls whether the menu item is enabled. Every time the keymap is -used to display a menu, Emacs evaluates the expression, and it enables -the menu item only if the expression's value is non-@code{nil}. When a -menu item is disabled, it is displayed in a ``fuzzy'' fashion, and -cannot be selected with the mouse. - -@subsection Menus and the Mouse - -The way to make a menu keymap produce a menu is to make it the -definition of a prefix key. - -When the prefix key ends with a mouse event, Emacs handles the menu -keymap by popping up a visible menu that you can select from with the -mouse. When you click on a menu item, the event generated is whatever -character or symbol has the binding which brought about that menu item. - -A single keymap can appear as multiple panes, if you explicitly -arrange for this. The way to do this is to make a keymap for each -pane, then create a binding for each of those maps in the main keymap -of the menu. Give each of these bindings a prompt string that starts -with @samp{@@}. The rest of the prompt string becomes the name of the -pane. See the file @file{lisp/mouse.el} for an example of this. Any -ordinary bindings with prompt strings are grouped into one pane, which -appears along with the other panes explicitly created for the -submaps. - -You can also get multiple panes from separate keymaps. The full -definition of a prefix key always comes from merging the definitions -supplied by the various active keymaps (minor modes, local, and -global). When more than one of these keymaps is a menu, each of them -makes a separate pane or panes. - -@subsection Menus and the Keyboard - -When a prefix key ending with a keyboard event (a character or function -key) has a definition that is a menu keymap, you can use the keyboard -to choose a menu item. - -Emacs displays the menu alternatives in the echo area. If they don't -all fit at once, type @key{SPC} to see the next line of alternatives. -If you keep typing @key{SPC}, you eventually get to the end of the menu -and then cycle around to the beginning again. - -When you have found the alternative you want, type the corresponding -character---the one whose binding is that alternative. - -In a menu intended for keyboard use, each menu item must clearly -indicate what character to type. The best convention to use is to make -the character the first letter of the menu item prompt string. That is -something users will understand without being told. - -@subsection The Menu Bar - - Under X Windows, each frame can have a @dfn{menu bar}---a permanently -displayed menu stretching horizontally across the top of the frame. The -items of the menu bar are the subcommands of the fake ``function key'' -@code{menu-bar}, as defined by all the active keymaps. - - To add an item to the menu bar, invent a fake ``function key'' of your -own (let's call it @var{key}), and make a binding for the key sequence -@code{[menu-bar @var{key}]}. Most often, the binding is a menu keymap, -so that pressing a button on the menu bar item leads to another menu. - - In order for a frame to display a menu bar, its @code{menu-bar-lines} -property must be greater than zero. Emacs uses just one line for the -menu bar itself; if you specify more than one line, the other lines -serve to separate the menu bar from the windows in the frame. We -recommend you try one or two as the @code{menu-bar-lines} value. - -@section Keymaps - -@itemize @bullet -@item -The representation of keymaps has changed to support the new event -types. All keymaps now have the form @code{(keymap @var{element} -@var{element} @dots{})}. Each @var{element} takes one of the following -forms: - -@table @asis -@item @var{prompt-string} -A string as an element of the keymap marks the keymap as a menu, and -serves as the overal prompt string for it. - -@item @code{(@var{key} . @var{binding})} -A cons cell binds @var{key} to @var{definition}. Here @var{key} may be -any sort of event head---a character, a function key symbol, or a mouse -button symbol. - -@item @var{vector} -A vector of 128 elements binds all the ASCII characters; the @var{n}th -element holds the binding for character number @var{n}. - -@item @code{(t . @var{binding})} -A cons cell whose @sc{car} is @code{t} is a default binding; anything -not bound by previous keymap elements is given @var{binding} as its -binding. - -Default bindings are important because they allow a keymap to bind all -possible events without having to enumerate all the possible function -keys and mouse clicks, with all possible modifier prefixes. - -The function @code{lookup-key} (and likewise other functions for -examining a key binding) normally report only explicit bindings of the -specified key sequence; if there is none, they return @code{nil}, even -if there is a default binding that would apply to that key sequence if -it were actually typed in. However, these functions now take an -optional argument @var{accept-defaults} which, if non-@code{nil}, says -to consider default bindings. - -Note that if a vector in the keymap binds an ASCII character to -@code{nil} (thus making it ``unbound''), the default binding does not -apply to the character. Think of the vector element as an explicit -binding of @code{nil}. - -Note also that if the keymap for a minor or major mode contains a -default binding, it completely masks out any lower-priority keymaps. -@end table - -@item -A keymap can now inherit from another keymap. Do do this, make the -latter keymap the ``tail'' of the new one. Such a keymap looks like -this: - -@example -(keymap @var{bindings}@dots{} . @var{other-keymap}) -@end example - -The effect is that this keymap inherits all the bindings of -@var{other-keymap}, but can add to them or override them with -@var{bindings}. Subsequent changes in the bindings of -@var{other-keymap} @emph{do} affect this keymap. - -For example, - -@example -(setq my-mode-map (cons 'keymap text-mode-map)) -@end example - -@noindent -makes a keymap that by default inherits all the bindings of Text -mode---whatever they may be at the time a key is looked up. Any -bindings made explicitly in @code{my-mode-map} override the bindings -inherited from Text mode, however. - -@item -Minor modes can now have local keymaps. Thus, a key can act a special -way when a minor mode is in effect, and then revert to the major mode or -global definition when the minor mode is no longer in effect. The -precedence of keymaps is now: minor modes (in no particular order), then -major mode, and lastly the global map. - -The new @code{current-minor-mode-maps} function returns a list of all -the keymaps of currently enabled minor modes, in the other that they -apply. - -To set up a keymap for a minor mode, add an element to the alist -@code{minor-mode-map-alist}. Its elements look like this: - -@example -(@var{symbol} . @var{keymap}) -@end example - -The keymap @var{keymap} is active whenever @var{symbol} has a -non-@code{nil} value. Use for @var{symbol} the variable which indicates -whether the minor mode is enabled. - -When more than one minor mode keymap is active, their order of -precedence is the order of @code{minor-mode-map-alist}. But you should -design minor modes so that they don't interfere with each other, and if -you do this properly, the order will not matter. - -The function @code{minor-mode-key-binding} returns a list of all the -active minor mode bindings of @var{key}. More precisely, it returns an -alist of pairs @code{(@var{modename} . @var{binding})}, where -@var{modename} is the the variable which enables the minor mode, and -@var{binding} is @var{key}'s definition in that mode. If @var{key} has -no minor-mode bindings, the value is @code{nil}. - -If the first binding is a non-prefix, all subsequent bindings from other -minor modes are omitted, since they would be completely shadowed. -Similarly, the list omits non-prefix bindings that follow prefix -bindings. - -@item -The new function @code{copy-keymap} copies a keymap, producing a new -keymap with the same key bindings in it. If the keymap contains other -keymaps directly, these subkeymaps are copied recursively. - -If you want to, you can define a prefix key with a binding that is a -symbol whose function definition is another keymap. In this case, -@code{copy-keymap} does not look past the symbol; it doesn't copy the -keymap inside the symbol. - -@item -@code{substitute-key-definition} now accepts an optional fourth -argument, which is a keymap to use as a template. - -@example -(substitute-key-definition olddef newdef keymap oldmap) -@end example - -@noindent -finds all characters defined in @var{oldmap} as @var{olddef}, -and defines them in @var{keymap} as @var{newdef}. - -In addition, this function now operates recursively on the keymaps that -define prefix keys within @var{keymap} and @var{oldmap}. -@end itemize - -@section Minibuffer Features - -The minibuffer input functions @code{read-from-minibuffer} and -@code{completing-read} have new features. - -@subsection Minibuffer History - -A new optional argument @var{hist} specifies which history list to use. -If you specify a variable (a symbol), that variable is the history -list. If you specify a cons cell @code{(@var{variable} -. @var{startpos})}, then @var{variable} is the history list variable, -and @var{startpos} specifies the initial history position (an integer, -counting from zero which specifies the most recent element of the -history). - -If you specify @var{startpos}, then you should also specify that element -of the history as @var{initial-input}, for consistency. - -If you don't specify @var{hist}, then the default history list -@code{minibuffer-history} is used. Other standard history lists that -you can use when appropriate include @code{query-replace-history}, -@code{command-history}, and @code{file-name-history}. - -The value of the history list variable is a list of strings, most recent -first. You should set a history list variable to @code{nil} before -using it for the first time. - -@code{read-from-minibuffer} and @code{completing-read} add new elements -to the history list automatically, and provide commands to allow the -user to reuse items on the list. The only thing your program needs to -do to use a history list is to initialize it and to pass its name to the -input functions when you wish. But it is safe to modify the list by -hand when the minibuffer input functions are not using it. - -@subsection Other Minibuffer Features - -The @var{initial} argument to @code{read-from-minibufer} and other -minibuffer input functions can now be a cons cell @code{(@var{string} -. @var{position})}. This means to start off with @var{string} in the -minibuffer, but put the cursor @var{position} characters from the -beginning, rather than at the end. - -In @code{read-no-blanks-input}, the @var{initial} argument is now -optional; if it is omitted, the initial input string is the empty -string. - -@section New Features for Defining Commands - -@itemize @bullet -@item -If the interactive specification begins with @samp{@@}, this means to -select the window under the mouse. This selection takes place before -doing anything else with the command. - -You can use both @samp{@@} and @samp{*} together in one command; they -are processed in order of appearance. - -@item -Prompts in an interactive specification can incorporate the values of -the preceding arguments. Emacs replaces @samp{%}-sequences (as used -with the @code{format} function) in the prompt with the interactive -arguments that have been read so far. For example, a command with this -interactive specification - -@example -(interactive "sReplace: \nsReplace %s with: ") -@end example - -@noindent -prompts for the first argument with @samp{Replace: }, and then prompts -for the second argument with @samp{Replace @var{foo} with: }, where -@var{foo} is the string read as the first argument. - -@item -If a command name has a property @code{enable-recursive-minibuffers} -which is non-@code{nil}, then the command can use the minibuffer to read -arguments even if it is invoked from the minibuffer. The minibuffer -command @code{next-matching-history-element} (normally bound to -@kbd{M-s} in the minibuffer) uses this feature. -@end itemize - -@section New Features for Reading Input - -@itemize @bullet -@item -The function @code{set-input-mode} now takes four arguments. The last -argument is optional. Their names are @var{interrupt}, @var{flow}, -@var{meta} and @var{quit}. - -The argument @var{interrupt} says whether to use interrupt-driven -input. Non-@code{nil} means yes, and @code{nil} means no (use CBREAK -mode). - -The argument @var{flow} says whether to enable terminal flow control. -Non-@code{nil} means yes. - -The argument @var{meta} says whether to enable the use of a Meta key. -Non-@code{nil} means yes. - -If @var{quit} non-@code{nil}, it is the character to use for quitting. -(Normally this is @kbd{C-g}.) - -@item -The variable @code{meta-flag} has been deleted; use -@code{set-input-mode} to enable or disable support for a @key{META} -key. This change was made because @code{set-input-mode} can send the -terminal the appropriate commands to enable or disable operation of the -@key{META} key. - -@item -The new variable @code{extra-keyboard-modifiers} lets Lisp programs -``press'' the modifier keys on the keyboard. -The value is a bit mask: - -@table @asis -@item 1 -The @key{SHIFT} key. -@item 2 -The @key{LOCK} key. -@item 4 -The @key{CTL} key. -@item 8 -The @key{META} key. -@end table - -When you use X windows, the program can press any of the modifier keys -in this way. Otherwise, only the @key{CTL} and @key{META} keys can be -virtually pressed. - -@item -You can use the new function @code{keyboard-translate} to set up -@code{keyboard-translate-table} conveniently. - -@item -Y-or-n questions using the @code{y-or-n-p} function now accept @kbd{C-]} -(usually mapped to @code{abort-recursive-edit}) as well as @kbd{C-g} to -quit. - -@item -The variable @code{num-input-keys} is the total number of key sequences -that the user has typed during this Emacs session. - -@item -A new Lisp variable, @code{function-key-map}, holds a keymap which -describes the character sequences sent by function keys on an ordinary -character terminal. This uses the same keymap data structure that is -used to hold bindings of key sequences, but it has a different meaning: -it specifies translations to make while reading a key sequence. - -If @code{function-key-map} ``binds'' a key sequence @var{k} to a vector -@var{v}, then when @var{k} appears as a subsequence @emph{anywhere} in a -key sequence, it is replaced with @var{v}. - -For example, VT100 terminals send @kbd{@key{ESC} O P} when the ``keypad'' -PF1 key is pressed. Thus, on a VT100, @code{function-key-map} should -``bind'' that sequence to @code{[pf1]}. This specifies translation of -@kbd{@key{ESC} O P} into @key{PF1} anywhere in a key sequence. - -Thus, typing @kbd{C-c @key{PF1}} sends the character sequence @kbd{C-c -@key{ESC} O P}, but @code{read-key-sequence} translates this back into -@kbd{C-c @key{PF1}}, which it returns as the vector @code{[?\C-c PF1]}. - -Entries in @code{function-key-map} are ignored if they conflict with -bindings made in the minor mode, local, or global keymaps. - -The value of @code{function-key-map} is usually set up automatically -according to the terminal's Terminfo or Termcap entry, and the -terminal-specific Lisp files. Emacs comes with a number of -terminal-specific files for many common terminals; their main purpose is -to make entries in @code{function-key-map} beyond those that can be -deduced from Termcap and Terminfo. - -@item -The variable @code{key-translation-map} works like @code{function-key-map} -except for two things: - -@itemize @bullet -@item -@code{key-translation-map} goes to work after @code{function-key-map} is -finished; it receives the results of translation by -@code{function-key-map}. - -@item -@code{key-translation-map} overrides actual key bindings. -@end itemize - -The intent of @code{key-translation-map} is for users to map one -character set to another, including ordinary characters normally bound -to @code{self-insert-command}. -@end itemize - -@section New Syntax Table Features - -@itemize @bullet -@item -You can use two new functions to move across characters in certain -syntax classes. - -@code{skip-syntax-forward} moves point forward across characters whose -syntax classes are mentioned in its first argument, a string. It stops -when it encounters the end of the buffer, or position @var{lim} (the -optional second argument), or a character it is not supposed to skip. -The function @code{skip-syntax-backward} is similar but moves backward. - -@item -The new function @code{forward-comment} moves point by comments. It -takes one argument, @var{count}; it moves point forward across -@var{count} comments (backward, if @var{count} is negative). If it -finds anything other than a comment or whitespace, it stops, leaving -point at the far side of the last comment found. It also stops after -satisfying @var{count}. - -@item -The new variable @code{words-include-escapes} affects the behavior of -@code{forward-word} and everything that uses it. If it is -non-@code{nil}, then characters in the ``escape'' and ``character -quote'' syntax classes count as part of words. - -@item -There are two new syntax flags for use in syntax tables. - -@itemize - -@item -The prefix flag. - -The @samp{p} flag identifies additional ``prefix characters'' in Lisp -syntax. You can set this flag with @code{modify-syntax-entry} by -including the letter @samp{p} in the syntax specification. - -These characters are treated as whitespace when they appear between -expressions. When they appear withing an expression, they are handled -according to their usual syntax codes. - -The function @code{backward-prefix-chars} moves back over these -characters, as well as over characters whose primary syntax class is -prefix (@samp{'}). - -@item -The @samp{b} comment style flag. - -Emacs can now supports two comment styles simultaneously. (This is for -the sake of C++.) More specifically, it can recognize two different -comment-start sequences. Both must share the same first character; only -the second character may differ. Mark the second character of the -@samp{b}-style comment start sequence with the @samp{b} flag. You can -set this flag with @code{modify-syntax-entry} by including the letter -@samp{b} in the syntax specification. - -The two styles of comment can have different comment-end sequences. A -comment-end sequence (one or two characters) applies to the @samp{b} -style if its first character has the @samp{b} flag set; otherwise, it -applies to the @samp{a} style. - -The appropriate comment syntax settings for C++ are as follows: - -@table @asis -@item @samp{/} -@samp{124b} -@item @samp{*} -@samp{23} -@item newline -@samp{>b} -@end table - -Thus @samp{/*} is a comment-start sequence for @samp{a} style, @samp{//} -is a comment-start sequence for @samp{b} style, @samp{*/} is a -comment-end sequence for @samp{a} style, and newline is a comment-end -sequence for @samp{b} style. -@end itemize -@end itemize - -@section The Case Table - -You can customize case conversion using the new case table feature. A -case table is a collection of strings that specifies the mapping between -upper case and lower case letters. Each buffer has its own case table. -You need a case table if you are using a language which has letters that -are not standard ASCII letters. - -A case table is a list of this form: - -@example -(@var{downcase} @var{upcase} @var{canonicalize} @var{equivalences}) -@end example - -@noindent -where each element is either @code{nil} or a string of length 256. The -element @var{downcase} says how to map each character to its lower-case -equivalent. The element @var{upcase} maps each character to its -upper-case equivalent. If lower and upper case characters are in 1-1 -correspondence, use @code{nil} for @var{upcase}; then Emacs deduces the -upcase table from @var{downcase}. - -For some languages, upper and lower case letters are not in 1-1 -correspondence. There may be two different lower case letters with the -same upper case equivalent. In these cases, you need to specify the -maps for both directions. - -The element @var{canonicalize} maps each character to a canonical -equivalent; any two characters that are related by case-conversion have -the same canonical equivalent character. - -The element @var{equivalences} is a map that cyclicly permutes each -equivalence class (of characters with the same canonical equivalent). - -You can provide @code{nil} for both @var{canonicalize} and -@var{equivalences}, in which case both are deduced from @var{downcase} -and @var{upcase}. - -Here are the functions for working with case tables: - -@code{case-table-p} is a predicate that says whether a Lisp object is a -valid case table. - -@code{set-standard-case-table} takes one argument and makes that -argument the case table for new buffers created subsequently. -@code{standard-case-table} returns the current value of the new buffer -case table. - -@code{current-case-table} returns the case table of the current buffer. -@code{set-case-table} sets the current buffer's case table to the -argument. - -@code{set-case-syntax-pair} is a convenient function for specifying a -pair of letters, upper case and lower case. Call it with two arguments, -the upper case letter and the lower case letter. It modifies the -standard case table and a few syntax tables that are predefined in -Emacs. This function is intended as a subroutine for packages that -define non-ASCII character sets. - -Load the library @file{iso-syntax} to set up the syntax and case table for -the 256 bit ISO Latin 1 character set. - -@section New Features for Dealing with Buffers - -@itemize @bullet -@item -The new function @code{buffer-modified-tick} returns a buffer's -modification-count that ticks every time the buffer is modified. It -takes one optional argument, which is the buffer you want to examine. -If the argument is @code{nil} (or omitted), the current buffer is used. - -@item -@code{buffer-disable-undo} is a new name for the function -formerly known as @code{buffer-flush-undo}. This turns off recording -of undo information in the buffer given as argument. - -@item -The new function @code{generate-new-buffer-name} chooses a name that -would be unique for a new buffer---but does not create the buffer. Give -it one argument, a starting name. It produces a name not in use for a -buffer by appending a number inside of @samp{<@dots{}>}. - -@item -The function @code{rename-buffer} now takes an option second argument -which tells it that if the specified new name corresponds to an existing -buffer, it should use @code{generate-new-buffer-name} to modify the name -to be unique, rather than signaling an error. - -@code{rename-buffer} now returns the name to which the buffer was -renamed. - -@item -The function @code{list-buffers} now looks at the local variable -@code{list-buffers-directory} in each non-file-visiting buffer, and -shows its value where the file would normally go. Dired sets this -variable in each Dired buffer, so the buffer list now shows which -directory each Dired buffer is editing. - -@item -The function @code{other-buffer} now takes an optional second argument -@var{visible-ok} which, if non-@code{nil}, indicates that buffers -currently being displayed in windows may be returned even if there are -other buffers not visible. Normally, @code{other-buffer} returns a -currently visible buffer only as a last resort, if there are no suitable -nonvisible buffers. - -@item -The hook @code{kill-buffer-hook} now runs whenever a buffer is killed. -@end itemize - -@section Local Variables Features - -@itemize @bullet -@item -If a local variable name has a non-@code{nil} @code{permanent-local} -property, then @code{kill-all-local-variables} does not kill it. Such -local variables are ``permanent''---they remain unchanged even if you -select a different major mode. - -Permanent locals are useful when they have to do with where the file -came from or how to save it, rather than with how to edit the contents. - -@item -The function @code{make-local-variable} now never changes the value of the variable -that it makes local. If the variable had no value before, it still has -no value after becoming local. - -@item -The new function @code{default-boundp} tells you whether a variable has -a default value (as opposed to being unbound in its default value). If -@code{(default-boundp 'foo)} returns @code{nil}, then -@code{(default-value 'foo)} would get an error. - -@code{default-boundp} is to @code{default-value} as @code{boundp} is to -@code{symbol-value}. - -@item -The special forms @code{defconst} and @code{defvar}, when the variable -is local in the current buffer, now set the variable's default value -rather than its local value. -@end itemize - -@section New Features for Subprocesses - -@itemize @bullet -@item -@code{call-process} and @code{call-process-region} now return a value -that indicates how the synchronous subprocess terminated. It is either -a number, which is the exit status of a process, or a signal name -represented as a string. - -@item -@code{process-status} now returns @code{open} and @code{closed} as the -status values for network connections. - -@item -The standard asynchronous subprocess features work on VMS now, -and the special VMS asynchronous subprocess functions have been deleted. - -@item -You can use the transaction queue feature for more convenient -communication with subprocesses using transactions. - -Call @code{tq-create} to create a transaction queue communicating with a -specified process. Then you can call @code{tq-enqueue} to send a -transaction. @code{tq-enqueue} takes these five arguments: - -@example -(tq-enqueue @var{tq} @var{question} @var{regexp} @var{closure} @var{fn}) -@end example - -@var{tq} is the queue to use. (Specifying the queue has the effect of -specifying the process to talk to.) The argument @var{question} is the -outgoing message which starts the transaction. The argument @var{fn} is -the function to call when the corresponding answer comes back; it is -called with two arguments: @var{closure}, and the answer received. - -The argument @var{regexp} is a regular expression to match the entire -answer; that's how @code{tq-enqueue} tells where the answer ends. - -Call @code{tq-close} to shut down a transaction queue and terminate its -subprocess. - -@item -The function @code{signal-process} sends a signal to process @var{pid}, -which need not be a child of Emacs. The second argument @var{signal} -specifies which signal to send; it should be an integer. -@end itemize - -@section New Features for Dealing with Times And Time Delays - -@itemize @bullet -@item -The new function @code{current-time} returns the system's time value as -a list of three integers: @code{(@var{high} @var{low} @var{microsec})}. -The integers @var{high} and @var{low} combine to give the number of -seconds since 0:00 January 1, 1970, which is @var{high} * 2**16 + -@var{low}. - -@var{microsec} gives the microseconds since the start of the current -second (or 0 for systems that return time only on the resolution of a -second). - -@item -The function @code{current-time-string} accepts an optional argument -@var{time-value}. If given, this specifies a time to format instead of -the current time. The argument should be a cons cell containing two -integers, or a list whose first two elements are integers. Thus, you -can use times obtained from @code{current-time} (see above) and from -@code{file-attributes}. - -@item -You can now find out the user's time zone using @code{current-time-zone}. -It takes no arguments, and returns a list of this form: - -@example -(@var{offset} @var{savings-flag} @var{standard} @var{savings}) -@end example - -@var{offset} is an integer specifying how many minutes east of Greenwich -the current time zone is located. A negative value means west of -Greenwich. Note that this describes the standard time; if daylight -savings time is in effect, it does not affect this value. - -@var{savings-flag} is non-@code{nil} iff daylight savings time or some other -sort of seasonal time adjustment is in effect. - -@var{standard} is a string giving the name of the time zone when no -seasonal time adjustment is in effect. - -@var{savings} is a string giving the name of the time zone when there is a -seasonal time adjustment in effect. - -If the user has specified a region that does not use a seasonal time -adjustment, @var{savings-flag} is always @code{nil}, and @var{standard} -and @var{savings} are equal. - -@item -@code{sit-for}, @code{sleep-for} now let you specify the time period in -milliseconds as well as in seconds. The first argument gives the number -of seconds, as before, and the optional second argument gives additional -milliseconds. The time periods specified by these two arguments are -added together. - -Not all systems support this; you get an error if you specify nonzero -milliseconds and it isn't supported. - -@code{sit-for} also accepts an optional third argument @var{nodisp}. If -this is non-@code{nil}, @code{sit-for} does not redisplay. It still -waits for the specified time or until input is available. - -@item -@code{accept-process-output} now accepts a timeout specified by optional -second and third arguments. The second argument specifies the number of -seconds, while the third specifies the number of milliseconds. The time -periods specified by these two arguments are added together. - -Not all systems support this; you get an error if you specify nonzero -milliseconds and it isn't supported. - -The function returns @code{nil} if the timeout expired before output -arrived, or non-@code{nil} if it did get some output. - -@item -You can set up a timer to call a function at a specified future time. -To do so, call @code{run-at-time}, like this: - -@example -(run-at-time @var{time} @var{repeat} @var{function} @var{args}@dots{}) -@end example - -Here, @var{time} is a string saying when to call the function. The -argument @var{function} is the function to call later, and @var{args} -are the arguments to give it when it is called. - -The argument @var{repeat} specifies how often to repeat the call. If -@var{repeat} is @code{nil}, there are no repetitions; @var{function} is -called just once, at @var{time}. If @var{repeat} is an integer, it -specifies a repetition period measured in seconds. - -Absolute times may be specified in a wide variety of formats; The form -@samp{@var{hour}:@var{min}:@var{sec} @var{timezone} -@var{month}/@var{day}/@var{year}}, where all fields are numbers, works; -the format that @code{current-time-string} returns is also allowed. - -To specify a relative time, use numbers followed by units. -For example: - -@table @samp -@item 1 min -denotes 1 minute from now. -@item 1 min 5 sec -denotes 65 seconds from now. -@item 1 min 2 sec 3 hour 4 day 5 week 6 fortnight 7 month 8 year -denotes exactly 103 months, 123 days, and 10862 seconds from now. -@end table - -If @var{time} is an integer, that specifies a relative time measured in -seconds. -@end itemize - -To cancel the requested future action, pass the value that @code{run-at-time} -returned to the function @code{cancel-timer}. - -@section Profiling Lisp Programs - -You can now make execution-time profiles of Emacs Lisp programs using -the @file{profile} library. See the file @file{profile.el} for -instructions; if you have written a Lisp program big enough to be worth -profiling, you can surely understand them. - -@section New Features for Lisp Debuggers - -@itemize @bullet -@item -You can now specify which kinds of errors should invoke the Lisp -debugger by setting the variable @code{debug-on-error} to a list of error -conditions. For example, if you set it to the list @code{(void-variable)}, -then only errors about a variable that has no value invoke the -debugger. - -@item -The variable @code{command-debug-status} is used by Lisp debuggers. It -records the debugging status of current interactive command. Each time -a command is called interactively, this variable is bound to -@code{nil}. The debugger can set this variable to leave information for -future debugger invocations during the same command. - -The advantage of this variable over some other variable in the debugger -itself is that the data will not be visible for any other command -invocation. - -@item -The function @code{backtrace-frame} is intended for use in Lisp -debuggers. It returns information about what a frame on the Lisp call -stack is doing. You specify one argument, which is the number of stack -frames to count up from the current execution point. - -If that stack frame has not evaluated the arguments yet (or is a special -form), the value is @code{(nil @var{function} @var{arg-forms}@dots{})}. - -If that stack frame has evaluated its arguments and called its function -already, the value is @code{(t @var{function} -@var{arg-values}@dots{})}. - -In the return value, @var{function} is whatever was supplied as @sc{car} -of evaluated list, or a @code{lambda} expression in the case of a macro -call. If the function has a @code{&rest} argument, that is represented -as the tail of the list @var{arg-values}. - -If the argument is out of range, @code{backtrace-frame} returns -@code{nil}. -@end itemize - -@ignore - -@item -@code{kill-ring-save} now gives visual feedback to indicate the region -of text being added to the kill ring. If the opposite end of the -region is visible in the current window, the cursor blinks there. -Otherwise, some text from the other end of the region is displayed in -the message area. -@end ignore - -@section Memory Allocation Changes - -The list that @code{garbage-collect} returns now has one additional -element. This is a cons cell containing two numbers. It gives -information about the number of used and free floating point numbers, -much as the first element gives such information about the number of -used and free cons cells. - -The new function @code{memory-limit} returns an indication of the last -address allocated by Emacs. More precisely, it returns that address -divided by 1024. You can use this to get a general idea of how your -actions affect the memory usage. - -@section Hook Changes - -@itemize @bullet -@item -Expanding an abbrev first runs the new hook -@code{pre-abbrev-expand-hook}. - -@item -The editor command loop runs the normal hook @code{pre-command-hook} -before each command, and runs @code{post-command-hook} after each -command. - -@item -Auto-saving runs the new hook @code{auto-save-hook} before actually -starting to save any files. - -@item -The new variable @code{revert-buffer-insert-file-contents-function} -holds a function that @code{revert-buffer} now uses to read in the -contents of the reverted buffer---instead of calling -@code{insert-file-contents}. - -@item -The variable @code{lisp-indent-hook} has been renamed to -@code{lisp-indent-function}. - -@item -The variable @code{auto-fill-hook} has been renamed to -@code{auto-fill-function}. - -@item -The variable @code{blink-paren-hook} has been renamed to -@code{blink-paren-function}. - -@item -The variable @code{temp-buffer-show-hook} has been renamed to -@code{temp-buffer-show-function}. - -@item -The variable @code{suspend-hook} has been renamed to -@code{suspend-hooks}, because it is a list of functions but is not a -normal hook. - -@item -The new function @code{add-hook} provides a handy way to add a function -to a hook variable. For example, - -@example -(add-hook 'text-mode-hook 'my-text-hook-function) -@end example - -@noindent -arranges to call @code{my-text-hook-function} -when entering Text mode or related modes. -@end itemize - -@bye
--- a/etc/termcap.dat Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1246 +0,0 @@ - -# This is termcap.dat, a copy of the /etc/termcap file included here -# for use on VMS. - -# I know that many terminals are missing from this version of the file -# because they were deleted at MIT. -# I hope that someone will add in all the missing terminal types -# and send me a corrected, larger file. - -# These are local terminals. - -v1|tvi912|912|920|tvi920|old televideo:\ - :ct=\E3:st=\E1:cr=^M:do=^J:nl=^J:bl=^G:\ - :al=33*\EE:le=^H:ce=\ET:cm=\E=%+ %+ :cl=^Z:co#80:dc=\EW:dl=33*\ER:ei=:\ - :kb=^h:ku=^K:kd=^J:kl=^H:kr=^L:k0=^A@\r:k1=^AA\r:k2=^AB\r:k3=^AC\r:\ - :bs:am:k4=^AD\r:k5=^AE\r:k6=^AF\r:k7=^AG\r:k8=^AH\r:k9=^AI\r:\ - :ho=^^:im=:ic=\EQ:li#24:nd=^L:ta=^I:pt:se=\Ek:so=\Ej:up=^K:us=\El:ue=\Em:\ - :ma=^K^P^L :sg#1:ug#1: -ZV|bobcat|sbobcat|HP 9000 model 300 console:\ - :al=10*\EL:am:bs:\ - :cd=\EJ:ce=\EK:ch=6\E&a%dC:cl=\EH\EJ:\ - :co#128:da:db:dc=\EP:dl=10*\EM:do=\EB:ei=\ER:\ - :kb=^H:kd=\EB:kh=\Eh:kl=\ED:kr=\EC:ku=\EA:\ - :ke=\E&s0A:ks=\E&s1A:\ - :li#47:mi:nd=\EC:pt:\ - :se=\E&d@:so=\E&dB:\ - :up=\EA:xs:\ - :cm=6\E&a%dy%dC:cv=6\E&a%dY:\ - :im=\EQ:ml=\El:mu=\Em:\ - :ue=\E&d@:us=\E&dD:bt=\Ei:sg#0: -ZX|gator-t|HP 9000 model 237 emulating extra-tall AAA:\ - :cr=^M:do=^J:nl=^J:bl=^G:al=\E[L:le=^H:bs:\ - :cd=\E[J:ce=\E[K:cl=\E[H\E[J:cm=\E[%i%d;%dH:co#128:li#94:\ - :dc=\E[P:dl=\E[M:ho=\E[H:ic=\E[@:\ - :AL=1*\E[%dL:DL=1*\E[%dM:IC=4\E[%d@:DC=4\E[%dP:rp=1*%.\E[%db:mr=\E[7m:me=\E[m:\ - :km:ch=\E[%i%d`:\ - :ul:ei=:im=:pt:bw:bt=\E[Z:\ - :mi:nd=\E[C:se=\E[m:so=\E[7m:ue=\E[m:us=\E[4m:up=\EM: -ZW|gator|HP 9000 model 237 emulating AAA:\ - :cr=^M:do=^J:nl=^J:bl=^G:al=\E[L:le=^H:bs:\ - :cd=\E[J:ce=\E[K:cl=\E[H\E[J:cm=\E[%i%d;%dH:co#128:li#47:\ - :dc=\E[P:dl=\E[M:ho=\E[H:ic=\E[@:\ - :AL=1*\E[%dL:DL=1*\E[%dM:IC=4\E[%d@:DC=4\E[%dP:rp=1*%.\E[%db:mr=\E[7m:me=\E[m:\ - :km:ch=\E[%i%d`:\ - :ul:ei=:im=:pt:bw:bt=\E[Z:\ - :mi:nd=\E[C:se=\E[m:so=\E[7m:ue=\E[m:us=\E[4m:up=\EM: -ZY|gator-52|HP 9000 model 237 emulating VT52:\ - :cr=^M:do=^J:nl=^J:bl=^G:\ - :le=^H:bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#128:li#47:nd=\EC:\ - :ta=^I:pt:sr=\EI:up=\EA:ku=\EA:kd=\EB:kr=\EC:kl=\ED:kb=^H:\ - :ce=\EK:ho=\EH: -ZZ|gator-52t|HP 9000 model 237 emulating extra-tall VT52:\ - :cr=^M:do=^J:nl=^J:bl=^G:\ - :le=^H:bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#128:li#94:nd=\EC:\ - :ta=^I:pt:sr=\EI:up=\EA:ku=\EA:kd=\EB:kr=\EC:kl=\ED:kb=^H:\ - :ce=\EK:ho=\EH: -# -# N: ANN ARBOR -# -N0|aa|annarbor|4080|ann arbor 4080:\ - :cr=^M:do=^J:nl=^J:bl=^G:pt:ct=^\^P^P:st=^]^P1:\ - :cm=^O%r%\066%.%>^S^L%+@:\ - :co#80:li#40:le=^H:bs:cl=2^L:up=^N:nd=^_:ho=^K:am:\ - :kb=^^:kd=^J:ku=^N:kl=^H:kr=^_:kh=^K:ma=^_ ^N^P: -# Needs function keys added. -# Originally from Mike O'Brien@Rand and Howard Katseff at Bell Labs. -# Highly modified 6/22 by Mike O'Brien. -# split out into several for the various screen sizes by dave-yost@rand -# Modifications made 3/82 by Mark Horton -# Modified by Tom Quarles at UCB for greater efficiency and more diversity -# status line moved to top of screen, vb removed 5/82 -# -# assumes the following setup: -# A: 0000 1010 0001 0000 -# B: 9600 0100 1000 0000 0000 1000 0000 17 19 -# C: 56 66 0 0 9600 0110 1100 -# D: 0110 1001 1 0 -# -# Briefly, the settings are for the following modes: -# (values are for bit set/clear with * indicating our preference -# and the value used to test these termcaps) -# Note that many of these settings are irrelevant to the termcap -# and are just set to the default mode of the terminal as shipped -# by the factory. -# -# A menu: 0000 1010 0001 0000 -# Block/underline cursor* -# blinking/nonblinking cursor* -# key click/no key click* -# bell/no bell at column 72* -# -# key pad is cursor control*/key pad is numeric -# return and line feed/return for <cr> key * -# repeat after .5 sec*/no repeat -# repeat at 25/15 chars per sec. * -# -# hold data until pause pressed/process data unless pause pressed* -# slow scroll/no slow scroll* -# Hold in area/don't hold in area* -# functions keys have default*/function keys disabled on powerup -# -# show/don't show position of cursor during page transmit* -# unused -# unused -# unused -# -# B menu: 9600 0100 1000 0000 0000 1000 0000 17 19 -# Baud rate (9600*) -# -# 2 bits of parity - 00=odd,01=even*,10=space,11=mark -# 1 stop bit*/2 stop bits -# parity error detection off*/on -# -# keyboard local/on line* -# half/full duplex* -# disable/do not disable keyboard after data transmission* -# -# transmit entire page/stop transmission at cursor* -# transfer/do not transfer protected characters* -# transmit all characters/transmit only selected characters* -# transmit all selected areas/transmit only 1 selected area* -# -# transmit/do not transmit line separators to host* -# transmit/do not transmit page tab stops tabs to host* -# transmit/do not transmit column tab stop tabs to host* -# transmit/do not transmit graphics control (underline,inverse..)* -# -# enable*/disable auto XON/XOFF control -# require/do not require receipt of a DC1 from host after each LF* -# pause key acts as a meta key/pause key is pause* -# unused -# -# unused -# unused -# unused -# unused -# -# XON character (17*) -# XOFF character (19*) -# -# C menu: 56 66 0 0 9600 0110 1100 -# number of lines to print data on (printer) (56*) -# -# number of lines on a sheet of paper (printer) (66*) -# -# left margin (printer) (0*) -# -# number of pad chars on new line to printer (0*) -# -# printer baud rate (9600*) -# -# printer parity: 00=odd,01=even*,10=space,11=mark -# printer stop bits: 2*/1 -# print/do not print guarded areas* -# -# new line is: 01=LF,10=CR,11=CRLF* -# unused -# unused -# -# D menu: 0110 1001 1 0 -# LF is newline/LF is down one line, same column* -# wrap to preceding line if move left from col 1*/don't wrap -# wrap to next line if move right from col 80*/don't wrap -# backspace is/is not destructive* -# -# display*/ignore DEL character -# display will not/will scroll* -# page/column tab stops* -# erase everything*/erase unprotected only -# -# editing extent: 0=display,1=line*,2=field,3=area -# -# unused -# -N1|aaa-29-np|aaa-29 with no padding (for psl):\ - :al=\E[L:ce=\E[K:cl=\E[H\E[J:\ - :dc=\E[P:dl=\E[M:ic=\E[@: -tc=aaa-29: -N2|aaa-unk|ann arbor ambassador (internal - don't use this directly):\ - :cr=^M:do=^J:nl=^J:bl=^G:al=1*\E[L:am:le=^H:bs:km:\ - :cd=7.2*\E[J:ce=5\E[K:cl=7.2*\E[H\E[J:cm=\E[%i%d;%dH:co#80:\ - :dc=4\E[P:dl=1*\E[M:ho=\E[H:ic=4\E[@:\ - :md=\E[1m:mr=\E[7m:mb=\E[5m:mk=\E[8m:me=\E[m:\ - :ku=\EM:kd=\ED:kl=\E[D:kr=\E[C:kh=\E[H:ce=\E[K:\ - :ks=\EP`?z~[H~[[J`>z~[[J`8xz~[M`4xz~[[D`6xz~[[C`2xz~[D\E\\:\ - :ke=\EP`?y~[H~[[J`>y~[[2J`8xy~[M`4xy~[[D`6xy~[[C`2xy~[D\E\\:\ - :ch=\E[%i%d`:\ - :ei=:im=:pt:bw:bt=\E[Z:\ - :mi:nd=\E[C:se=\E[m:so=\E[7m:ue=\E[m:us=\E[4m:up=\EM:\ - :AL=1*\E[%dL:DL=1*\E[%dM:IC=4\E[%d@:DC=4\E[%dP:\ - :cS=\E[%d;%d;%d;%dp:\ - :vs=\E[>52;54h\E[>30;37;38;39l:ve=\E[>52l\E[>37h: -# All the ti strings used to start with \E[2J, which cleared the screen. -# But this was so slow that it caused ^S/^Q lossage. -# So I removed the \E[2J's. -- rms, 1/29/86 -N3|aaa-18|ann arbor ambassador/18 lines:\ - :ti=\E[18;0;0;18p:\ - :te=\E[60;0;0;18p\E[18;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;18p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#18:tc=aaa-unk: -N4|aaa-20|ann arbor ambassador/20 lines:\ - :ti=\E[20;0;0;20p:\ - :te=\E[60;0;0;20p\E[20;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;20p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#20:tc=aaa-unk: -N5|aaa-22|ann arbor ambassador/22 lines:\ - :ti=\E[22;0;0;22p:\ - :te=\E[60;0;0;22p\E[22;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;22p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#22:tc=aaa-unk: -N6|aaa-24|ann arbor ambassador/24 lines:\ - :ti=\E[24;0;0;24p:\ - :te=\E[60;0;0;24p\E[24;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;24p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#24:tc=aaa-unk: -N7|aaa-26|ann arbor ambassador/26 lines:\ - :ti=\E[26;0;0;26p:\ - :te=\E[60;0;0;26p\E[26;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;26p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#26:tc=aaa-unk: -N8|aaa-28|ann arbor ambassador/28 lines:\ - :ti=\E[28;0;0;28p:\ - :te=\E[60;0;0;28p\E[28;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;28p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#28:tc=aaa-unk: -N9|aaa|ambassador|aaa-30|ann arbor ambassador/30 lines:\ - :ti=\E[30;0;0;30p:\ - :te=\E[60;0;0;30p\E[30;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[30;0;0;30p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#30:tc=aaa-unk: -NA|aaa-36|ann arbor ambassador/36 lines:\ - :ti=\E[36;0;0;36p:\ - :te=\E[60;0;0;36p\E[36;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;36p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#36:tc=aaa-unk: -NB|aaa-40|ann arbor ambassador/40 lines:\ - :ti=\E[40;0;0;40p:\ - :te=\E[60;0;0;40p\E[40;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;40p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#40:tc=aaa-unk: -NC|aaa-48|ann arbor ambassador/48 lines:\ - :ti=\E[48;0;0;48p:\ - :te=\E[60;0;0;48p\E[48;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;48p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#48:tc=aaa-unk: -ND|aaa-60|ann arbor ambassador/60 lines:\ - :ti=\E[60;0;0;60p:\ - :te=\E[60;0;0;60p\E[60;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;60p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#60:tc=aaa-unk: -NE|aaa-unk-s|ann arbor ambassador unknown with/status:\ - :hs:es:i2=\E7\E[>51h\E[H\E[2K\E[>51l\E8:\ - :ts=\E7\E[>51h\E[H\E[2K\E[%i%d`:fs=\E[>51l\E8:\ - :ds=\E7\E[>51h\E[H\E[2K\E[>51l\E8:\ - :tc=aaa-unk: -NF|aaa-18-s|ann arbor ambassador/18 lines + status line:\ - :ti=\E[18;1;0;18p:\ - :te=\E[60;1;0;18p\E[17;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;18p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#17:tc=aaa-unk-s: -NG|aaa-20-s|ann arbor ambassador/20 lines + status line:\ - :ti=\E[20;1;0;20p:\ - :te=\E[60;1;0;20p\E[19;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;20p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#19:tc=aaa-unk-s: -NH|aaa-22-s|ann arbor ambassador/22 lines + status line:\ - :ti=\E[22;1;0;22p:\ - :te=\E[60;1;0;22p\E[21;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;22p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#21:tc=aaa-unk-s: -NI|aaa-24-s|ann arbor ambassador/24 lines + status line:\ - :ti=\E[24;1;0;24p:\ - :te=\E[60;1;0;24p\E[23;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;24p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#23:tc=aaa-unk-s: -NJ|aaa-26-s|ann arbor ambassador/26 lines + status line:\ - :ti=\E[26;1;0;26p:\ - :te=\E[60;1;0;26p\E[25;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;26p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#25:tc=aaa-unk-s: -NK|aaa-28-s|ann arbor ambassador/28 lines + status line:\ - :ti=\E[28;1;0;28p:\ - :te=\E[60;1;0;28p\E[27;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;28p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#27:tc=aaa-unk-s: -NL|aaa-30-s|ann arbor ambassador/30 lines + status line:\ - :ti=\E[30;1;0;30p:\ - :te=\E[60;1;0;30p\E[29;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;30p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#29:tc=aaa-unk-s: -NM|aaa-36-s|ann arbor ambassador/36 lines + status line:\ - :ti=\E[36;1;0;36p:\ - :te=\E[60;1;0;36p\E[35;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;36p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#35:tc=aaa-unk-s: -NN|aaa-40-s|ann arbor ambassador/40 lines + status line:\ - :ti=\E[40;1;0;40p:\ - :te=\E[60;1;0;40p\E[39;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;40p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#39:tc=aaa-unk-s: -NO|aaa-48-s|ann arbor ambassador/48 lines+sl:\ - :ti=\E[48;1;0;48p:te=\E[60;1;0;48p\E[47;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\EP`?y~[[2J~[[H\E7\E[60;1;0;48p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#47:tc=aaa-unk-s: -NP|aaa-60-s|ann arbor ambassador/60 lines + status line:\ - :ti=\E[60;1;0;60p:te=\E[60;1;0;60p\E[59;1H\E[J:\ - :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;60p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :li#59:tc=aaa-unk-s: -NQ|aaa-18-rv|ambassador/18 lines+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;18p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-18: -NR|aaa-20-rv|ambassador/20 lines+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;20p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-20: -NS|aaa-22-rv|ambassador/22 lines+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;22p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-22: -NT|aaa-24-rv|ambassador/24 lines+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;24p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-24: -NU|aaa-26-rv|ambassador/26 lines+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;26p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-26: -NV|aaa-28-rv|ambassador/28 lines+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;28p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-28: -NW|aaa-30-rv|ann arbor ambassador/30 lines in reverse video:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;30p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-30: -NX|aaa-36-rv|ann arbor ambassador/36 lines in reverse video:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;36p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-36: -NY|aaa-40-rv|ann arbor ambassador/40 lines in reverse video:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;40p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-40: -NZ|aaa-48-rv|ann arbor ambassador/48 lines in reverse video:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;48p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-48: -Na|aaa-60-rv|ann arbor ambassador/60 lines in reverse video:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;60p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-60: -Nb|aaa-18-rv-s|aaa-18-s-rv|ambassador/18 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;18p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-18-s: -Nc|aaa-20-rv-s|aaa-20-s-rv|ambassador/20 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;20p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-20-s: -Nd|aaa-22-rv-s|aaa-22-s-rv|ambassador/22 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;22p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-22-s: -Ne|aaa-24-rv-s|aaa-24-s-rv|ambassador/24 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;24p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-24-s: -Nf|aaa-26-rv-s|aaa-26-s-rv|ambassador/26 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;26p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-26-s: -Ng|aaa-28-rv-s|aaa-28-s-rv|ambassador/28 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;28p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-28-s: -Nh|aaa-30-rv-s|aaa-30-s-rv|ambassador/30 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;30p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-30-s: -Ni|aaa-36-rv-s|aaa-36-s-rv|ambassador/36 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;36p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-36-s: -Nj|aaa-40-rv-s|aaa-40-s-rv|ambassador/40 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;40p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-40-s: -Nk|aaa-48-rv-s|aaa-48-s-rv|ambassador/48 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;48p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-48-s: -Nl|aaa-60-rv-s|aaa-60-s-rv|ambassador/60 lines+sl+rv:\ - :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\ - :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\ - :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;60p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\ - :tc=aaa-60-s: -Nm|aaa-24-ctxt:\ - :ti=\E[30;1H\E[K\E[24;0;0;24p:te=\E[60;1;0;24p\E[60;1H\E[K:tc=aaa-24: -Nn|aaa-24-rv-ctxt:\ - :ti=\E[30;1H\E[K\E[24;0;0;24p:te=\E[60;1;0;24p\E[60;1H\E[K:tc=aaa-24-rv: -No|aaa-30-s-ctxt:\ - :ti=\E[30;1H\E[K\E[30;1;0;30p:te=\E[60;1;0;30p\E[59;1H\E[K:tc=aaa-30-s: -Np|aaa-30-s-rv-ctxt:\ - :ti=\E[30;1H\E[K\E[30;1;0;30p:\ - :te=\E[60;1;0;30p\E[59;1H\E[K:tc=aaa-30-s-rv: -Nq|aaa-ctxt|aaa-30-ctxt:\ - :ti=\E[30;0;0;30p:te=\E[60;0;0;30p\E[60;1H\E[K:tc=aaa-30: -Nr|aaa-rv-ctxt|aaa-30-rv-ctxt:\ - :ti=\E[30;0;0;30p:te=\E[60;0;0;30p\E[60;1H\E[K:tc=aaa-30-rv: -Ns|aaa-db|ann arbor ambassador 30/destructive backspace:\ - :ti=\E[H\E[J\E[30;0;0;30p:te=\E7\E[60;0;0;30p\E8:li#30:\ - :is=\E[60;0;0;30p\E[H\E[J\E[1Q\E[m\E[20l\E[>30h:le=\E[D:bc=\E[D:bs@:\ - :tc=aaa-unk: -#Kludge for supdup -aaa-supdup|ann arbor ambassador 30/ for supdup :\ - :ns:tc=aaa-30: - -# -# yet another attempt at the aaa terminal from CCA: -# -ZJ|aaax|ambasx|ambassadorx|ann arbor ambassador base descriptor/:\ - :al=\E[L:bs:bt=\E[Z:bw:\ - :cd=\E[J:ce=\E[K:ch=\E[%i%d`:cl=\E[H\E[2J:cm=\E[%i%d;%dH:co#80:\ - :cv=\E[%i%dd:da:db:dc=\E[P:dl=\E[M:ho=\E[H:ic=\E[@:\ - :mi:nd=\E[C:pt:sf=\E[S:sr=\E[T:se=\E[m:so=\E[7m:\ - :km:mm=\E[>52h:mo=\E[>52l:\ - :ue=\E[m:up=\E[A:us=\E[4m: -ZK|aaa48|ambas|ambassador|ann arbor ambassador/48 lines:\ - :is=\E[48;0;0;48p\E[H\E[J\E[1Q\E[m\E[>30l\E[>26l\E[>32h\E[>33h\E[>52h:\ - :li#48:mi:tc=aaax: -ZL|aaa24|ambas24|ambassador24|ann arbor ambassador/24 lines:\ - :is=\E[24;0;0;24p\E[H\E[J\E[1Q\E[m\E[>30l\E[>26l\E[>32h\E[>33h\E[>52h:\ - :li#24:mi:tc=aaax: -ZM|aaa30|ambas30|ambassador30|ann arbor ambassador/30 lines:\ - :is=\E[30;0;0;30p\E[H\E[J\E[1Q\E[m\E[>30l\E[>26l\E[>32h\E[>33h\E[>52h:\ - :li#30:mi:tc=aaax: -ZN|aaa60|ambas60|ambassador60|ann arbor ambassador/60 lines:\ - :is=\E[60;0;0;60p\E[H\E[J\E[1Q\E[m\E[>30l\E[>26l\E[>32h\E[>33h\E[>52h:\ - :li#60:mi:tc=aaax: -# vt100 -- this has been changed to delete the "pt" ("real tabs") -# option, which was losing. -- walter 10/84 -d0|vt100-132|vt125-132|dec vt100 with 132 columns:\ - :co#132:tc=vt100: -d0|vt100|vt100-am|vt100-80|vt125|vt125-80|dec vt100:\ - :cr=^M:bl=^G:le=^H:do=\ED:ho=\E[H:\ - :co#80:li#24:cl=45\E[H\E[2J:bs:am:cm=5\E[%i%d;%dH:nd=\E[C:up=\E[A:\ - :ce=2\E[K:cd=2*\E[J:so=2\E[7m:se=2\E[m:us=2\E[4m:ue=2\E[m:\ - :md=2\E[1m:mr=2\E[7m:mb=2\E[5m:me=2\E[m:\ - :is=\E<\E[m\E>\E[?7h\E[?3;4;6l\200\200\200\200\200\200\200\200:\ - :rs=\E<\E[m\E>\E[?7h\E[?3;4;6l\200\200\200\200\200\200\200\200:\ - :ku=\EOA:kd=\EOB:kr=\EOC:kl=\EOD:kb=^H:\ - :cs=\E[%i%d;%dr:ks=\E[?1h\E=:ke=\E[?1l\E>:\ - :kh=\E[H:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:ta=^I:sf=5\ED:sr=5\EM:xn:\ - :dN#4:vt#3:sc=\E7:rc=\E8: -d0|vt132-132|dec vt132 with 132 columns:\ - :al=99\E[L:dl=99\E[M:ip=7:dc=7\E[P:ei=\E[4l:im=\E[4h:xn:dN#30:\ - :co#132:tc=vt100: -d0|vt132|vt132-80|dec vt132 with 80 columns:\ - :al=99\E[L:dl=99\E[M:ip=7:dc=7\E[P:ei=\E[4l:im=\E[4h:xn:dN#30:tc=vt100: - -dw|vt52|vt52-80|dec vt52:\ - :cr=^M:do=^J:nl=^J:bl=^G:\ - :le=^H:bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#80:li#24:nd=\EC:\ - :ta=^I:pt:sr=\EI:up=\EA:ku=\EA:kd=\EB:kr=\EC:kl=\ED:kb=^H: - -# Sun workstation consoles -Mu|sun|Sun Microsystems Workstation console:\ - :li#34:co#80:cl=^L:cm=\E[%i%d;%dH:nd=\E[C:up=\E[A:\ - :am:bs:km:mi:ms:pt:\ - :ce=\E[K:cd=\E[J:so=\E[7m:se=\E[m:rs=\E[s:\ - :kd=\E[B:kl=\E[D:ku=\E[A:kr=\E[C:kh=\E[H:\ - :k1=\E[224z:k2=\E[225z:k3=\E[226z:k4=\E[227z:k5=\E[228z:\ - :k6=\E[229z:k7=\E[230z:k8=\E[231z:k9=\E[232z:\ - :al=\E[L:dl=\E[M:im=:ei=:ic=\E[@:dc=\E[P:\ - :AL=\E[%dL:DL=\E[%dM:IC=\E[%d@:DC=\E[%dP: -# From john@ucbrenoir Tue Sep 24 13:14:44 1985 -Mu|sun-s|Sun Microsystems Workstation window with status line:\ - :hs:ts=\E]l:fs=\E\\:ds=\E]l\E\\:tc=sun -Mu|sun-e-s|sun-s-e|Sun Microsystems Workstation with status hacked for emacs:\ - :hs:ts=\E]l:fs=\E\\:ds=\E]l\E\\:tc=sun-e: -M0|sun-48|Sun 48-line window:\ - :li#48:co#80:tc=sun: -M1|sun-34|Sun 34-line window:\ - :li#34:co#80:tc=sun: -M2|sun-24|Sun 24-line window:\ - :li#24:co#80:tc=sun: -M3|sun-17|Sun 17-line window:\ - :li#17:co#80:tc=sun: -M4|sun-12|Sun 12-line window:\ - :li#12:co#80:tc=sun: -M5|sun-1|Sun 1-line window for sysline:\ - :li#1:co#80:es:hs:ts=\r:fs=\E[K:ds=^L:tc=sun: -M6|sun-e|sun-nic|sune|Sun Microsystems Workstation without insert character:\ - :ic@:im@:ei@:tc=sun: - -# Nu machine parameters taken from mit-vax. -# smc - 5/21/85 -# -dg|nuterminal:\ - :al=1*\EL:am:bs:cd=60\EJ:ce=10\EK:cl=60\EE:cm=10\EY%+ %+ :\ - co#80:dc=2.5*\EN:\ - :dl=1*\EM:do=\EB:ei=\EO:ho=\EH:im=\E@:ip=2.5*:li#24:mi:nd=\EC:\ - :as=\EF:ae=\EG:\ - :ms:pt:sr=\EI:se=\Eq:so=\Ep:up=\EA:vs=\Ex4:ve=\Ey4:\ - :kb=^h:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\EH:kn#8:\ - :k1=\ES:k2=\ET:k3=\EU:k4=\EV:k5=\EW:\ - :l6=blue:l7=red:l8=white:k6=\EP:k7=\EQ:k8=\ER: -nu|nu24|nuwindow:\ - :al=1*\EL:bs:cd=\EJ:ce=\EK:cl=\EE:cm=\EY%+ %+ :co#86:\ - :dl=1*\EM:do=\EB:ei=\EO:ho=\EH:im=\E@:ip=2.5*:li#24:mi:nd=\EC:\ - :as=\EF:ae=\EG:\ - :ms:pt:sr=\EI:se=\Eq:so=\Ep:up=\EA:vs=\Ex4:ve=\Ey4:\ - :kb=^h:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\EH: -bnu|nu51|bnuwindow:\ - :co#86:li#51:tc=nu: -fnu|nu61|fnuwindow:\ - :co#86:li#61:tc=nu: -nunix-30|nu-telnet-30|nu-half: Half nu screen thru telnet:\ - :am:al=\EL:bs:cd=\EJ:ce=\EK:cl=\EE:cm=\EY%+ %+ :co#78:\ - :dl=\EM:do=\EB:ip=2.5*:ho=\EH:li#30:nd=\EC:\ - :pt:sr=\EI:se=\Eq:so=\Ep:up=\EA: -nunix-61|nu-telnet-61|nu-full| Full nu screen thru telnet:\ - :co#78:li#61:tc=nunix-30: - -## VT200 entry for VMS. Also for VT300. -# Make sure not to use \n for nl or anything else. -# It is bad form to use ^J,^L,^K to scroll the screen. -# If the VT2xx doesn't have newline mode set those characters -# donot move the cursor down a line. Use \ED instead. -d0|vt200-80|vt200|vt300-80|VT 200 with 80 columns, on VMS:\ - :AL=\E[%dL:DC=\E[%dP:DL=\E[%dM:DO=\E[%dB:IC=\E[%d@:\ - :LE=\E[%dD:RI=\E[%dC:SR=1*\E[%dM:UP=\E[%dA:al=\E[L:\ - :am:bl=^G:bs:cd=2*\E[J:ce=2*\E[K:cl=45\E[H\E[2J:\ - :cm=%i\E[%d;%dH:co#80:cr=\r:cs=\E[%i%d;%dr:ct=\E[3g:\ - :dc=\E[P:dl=\E[M:dm=:do=\ED:ec=\E[%dX:ed=:ei=\E[4l:\ - :ho=\E[H:ic:im=\E[4h:it#8:k1=\EOP:k2=\EOQ:k3=\EOR:\ - :k4=\EOS:kd=\E[B:ke=\E[?1l\E>:kl=\E[D:kn#4:kr=\E[C:ks=\E[?1h\E=:\ - :ku=\E[A:le=^H:li#24:mb=\E[5m:md=\E[1m:me=\E[0m:mi:\ - :mr=\E[7m:ms:nd=\E[C:nl=\ED:nw=\EE:pf=\E[?4i:po=\E[?5i:\ - :ps=\E[i:rc=\E8:sc=\E7:se=\E[27m:sf=1*\ED:so=\E[7m:\ - :sr=1*\EM:st=\EH:ue=\E[24m:up=\EM:us=\E[4m:xn: -d0|vt200-132|vt300-132|VT 200 with 132 columns, on VMS:\ - :co#132:tc=vt200-80: - -aP|apollo_15P|apollo 15 inch display:\ - :dN@:tc=vt132: -aQ|apollo_19L|apollo 19 inch display:\ - :dN@:tc=vt132: -aR|apollo_color|apollo color display:\ - :dN@:tc=vt132: -aS|apollo_800_color|apollo 800 line color display:\ - :dN@:tc=vt132: -d3|vt132|vt-132:\ - :al=99\E[L:dl=99\E[M:ip=7:dc=7\E[P:ei=\E[4l:im=\E[4h:xn:dN#30:tc=vt100: -d0|vt100|vt100n|vt100 with no init:\ - :co#80:li#24:am:bs:pt:xn:cl=45\E[H\E[2J:\ - :cm=%i\E[%d;%dH:nd=\E[C:up=\EM:ho=\E[H:ce=2\E[K:cd=2*\E[J:\ - :nl=\EE:cr=\r:sr=5\EM:sf=30\E7\E[200H\ED\E8:\ - :sc=\E7:rc=\E8:cs=\E[%i%d;%dr:so=\E[7m:se=\E[m:us=\E[4m:ue=\E[m:LC:\ - :kl=\E[D:kr=\E[C:ku=\E[A:kd=\E[B:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS: -# ************************************************************************* -# Added for del to use a 132 char width terminal -# -d0|vt100l|vt100n|vt100 with no init:\ - :co#132:li#24:am:bs:pt:xn:cl=45\E[H\E[2J:\ - :cm=%i\E[%d;%dH:nd=\E[C:up=\EM:ho=\E[H:ce=2\E[K:cd=2*\E[J:\ - :nl=\EE:cr=\r:sr=5\EM:sf=30\E7\E[200H\ED\E8:\ - :sc=\E7:rc=\E8:cs=\E[%i%d;%dr:so=\E[7m:se=\E[m:us=\E[4m:ue=\E[m:LC:\ - :kl=\E[D:kr=\E[C:ku=\E[A:kd=\E[B:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS: -# -# End of "Add for del" -# ************************************************************************** -df|vt100|vt-100|vt100f|pt100|pt-100|dec vt100 (fast scroll, reverse video):\ - :is=\E>\E[?4l\E[?5h\E[?7h\E[?8h:\ - :if=/usr/lib/tabset/vt100:tc=vt100n: -d1|vt100|vt100fnv|dec vt100 (fast scroll, normal video):\ - :is=\E>\E[?4l\E[?5l\E[?7h\E[?8h:\ - :if=/usr/lib/tabset/vt100:tc=vt100n: -ds|vt100|vt100s|dec vt100 (smooth scroll, reverse video):\ - :is=\E>\E[?4h\E[?5h\E[?7h\E[?8h:\ - :if=/usr/lib/tabset/vt100:tc=vt100n: -dn|vt100|vt100snv|dec vt100 (smooth scroll, normal video):\ - :is=\E>\E[?4h\E[?5l\E[?7h\E[?8h:\ - :if=/usr/lib/tabset/vt100:tc=vt100n: -# This was designed for a VT320 emulator, but it is probably a good start -# at support for the VT320 itself. -# Please send changes with explanations to bug-gnu-emacs@prep.ai.mit.edu. -k3|vt320|vt320-k3|kermit|MS-Kermit 3.00's vt320 emulation:\ - :AL=\E[%dL:CC=\E:DL=\E[%dM:IC=\E[%d@:DC=\E[%dP:DO=\E[%dB:LE=\E[%dD:\ - :RI=\E[%dC:SR=\E[%dL:UP=\E[%dA:ae=\E(B:al=\E[L:am:as=\E(0:bl=^G:\ - :cd=\E[J:ce=\E[K:ch=\E[%i%dG:cl=\E[H\E[J:cm=\E[%i%d;%dH:co#80:cr=^M:\ - :cs=\E[%i%d;%dr:ct=\E[3g:cv=\E[%i%dd:dc=\E[P:do=^J:dl=\E[M:ds=\E[0$~:\ - :ec=\E[%dX:ei=\E[4l:es:fs=\E[0$}:ho=\E[H:hs:im=\E[4h:\ - :is=\E>\E F\E[?1l\E[?7h\E[r\E[2$~:k1=\EOP:k2=\EOQ:\ - :k3=\EOR:k4=\EOS:k6=\E[17~:k7=\E[18~:k8=\E[19~:k9=\E[20~:k0=\E[21~:\ - :kI=\E[2~:kL=\E[3~:kN=\E[6~:kP=\E[5~:kb=^H:kd=\EOB:ke=\E[?1l\E>:\ - :kl=\EOD:km:kn#20:kr=\EOC:ks=\E[?1h\E=:ku=\EOA:\ - :le=^H:li#49:mb=\E[5m:md=\E[1m:me=\E[m:mi:mr=\E[7m:ms:nd=\E[C:\ - :nl=^J:pb#9600:po=\E[5i:pf=\E[4i:ps=\E[0i:pt:rc=\E8:\ - :rs=\E(B\E)B\E>\E F\E[4;20l\E[12h\E[?1;5;6;38;42l\E[?7;25h\E4i\E?4i\E[m\E[r\E[2$~:\ - :sc=\E7:se=\E[27m:sf=^J:so=\E[7m:sr=\EM:st=\EH:ta=^I:\ - :ts=\E[1$}^M\E[K:ue=\E[24m:\ - :up=\E[A:us=\E[4m:vb=\E[?5h\E[?5l\E[?5h\E[?5l\E[?5h\E[?5l:ve=\E[?25h:\ - :vi=\E[?25l:vt#3:xn: -sw|switch|intelligent switch:co#80:os:am: -su|dumb|un|unknown:co#80:os:am: -sp|plugboard:co#80:os:am: -sa|arpanet|network:co#80:os:am: -sd|du|dialup:co#80:os:am: -sb|bussiplexer:co#80:os:am: -# Note that all of these claim to be "c100" in order to please the -# pen and emacs editors. If the user does a "tset c100" he will get co. -co|c100|concept|concept100|concept 100:\ - :is=\EU\Ef\E7\E5\E8\El\ENH\EK\E\200\Eo&\200\Eo\47\E:\ - :al=3*\E^R:am:bs:cd=16*\E^C:ce=16\E^S:cl=2*^L:cm=\Ea%+ %+ :co#80:\ - :dc=16\E^A:dl=3*\E^B:ei=\E\200:eo:im=\E^P:in:ip=16*:li#24:mi:nd=\E=:\ - :pt:kb=^h:so=\ENh:se=\ENH:ta=8\t:ul:up=\E;:db:xn:vs=\EW:ve=\Ew:\ - :vb=\Ek\200\200\200\200\200\200\200\200\200\200\200\200\200\200\EK:\ - :us=\EG:ue=\Eg:ks=\EX\ES:ke=\Ex\Es:ku=\E;:kd=\E<:kl=\E>:kr=\E=:kh=\E?:\ - :k1=\E5:k2=\E6:k3=\E7:.dN#9:dC#9: -c4|c100|c1004p|c100 w/4 pages:\ - :ti=\EU\Ev 8p\Ep\r:te=\Ev ~p\Ep\r\n:vs@:ve@:tc=concept: -cP|c100|c100rv4ppp|c100 with printer port:\ - :is=\EU\Ef\E7\E5\E8\El\ENH\Ek\E\200\Eo&\200\Eo!\200\EQ"\EY(^W\Eo\47\E:\ - :tc=c100rv4p: -cR|c100|c100rv4p|c100 w/4 pages:\ - :ti=\EU\Ev 8p\Ep\r:te=\Ev ~p\Ep\r\n:tc=c100rv: -# Some tty drivers use cr3 for concept, others use nl3, hence dN/dC below. -cd|c100|c100rvs|slow reverse concept 100:\ - :vb=\EK\200\Ek:pt:dC@:dN@:tc=c100rv: -cn|c100|c100rv4pna|c100 with no arrows:ks@:ke@:tc=c100rv4p: -cr|c100|c100rv|c100 rev video:\ - :is=\EU\Ef\E7\E5\E8\El\ENH\Ek\E\200\Eo&\200\Eo\47\E:vs@:ve@:\ - :vb=\EK\200\200\200\200\200\200\200\200\200\200\200\200\200\200\Ek:\ - :tc=concept: -cs|c100|c100s|slowconcept|slowconcept100|slow concept 100:\ - :vb=\Ek\200\EK:pt:dC@:dN@:tc=concept: -# vt100 and vt132 are still untested -# Note that all of these claim to be "vt100", so the first one wins. -dG|gigi|GIGI|dec gigi (naively treated as a straight vt100):\ - :tc=vt100n: -dR|vt125|dec vt125 (naively treated as a straight vt100; R for ReGIS):\ - :tc=vt100n: -kA|h19A|heathA|h19A|heathkitA|heathkit h19 ansi mode:\ - :al=1*\E[1L:am:bs:cd=\E[J:ce=\E[K:cl=\E[2J:cm=\E[%i%2;%2H:co#80:\ - :dc=\E[1P:dl=1*\E[1M:dn=\E[1B:ei=\E[4l:ho=\E[H:im=\E[4h:li#24:mi:\ - :nd=\E[1C:as=\E[10m:ae=\E[11m:ms:pt:se=\E[0m:so=\E[7m:up=\E[1A:\ - :vs=\E[>4h:ve=\E[>4l:kb=^h:ku=\E[1A:kd=\E[1B:kl=\E[1D:kr=\E[1C:\ - :kh=\E[H:kn#8:k1=\EOS:k2=\EOT:k3=\EOU:k4=\EOV:k5=\EOW:l6=blue:\ - :l7=red:l8=white:k6=\EOP:k7=\EOQ:k8=\EOR:\ - :sr=\EM:is=\E<\E[>1;2;3;4;5;6;7;8;9l\E[0m\E[11m\E[?7h: -kB|h19bs|heathkit w/keypad shifted:ks=\Et:ke=\Eu:tc=h19b: -kU|h19us|heathkit w/keypad shifted/underscore cursor:ks=\Et:ke=\Eu:tc=h19u: -kb|h19|heath|h19b|heathkit|heath-19|z19|zenith|heathkit h19:\ - :al=1*\EL:am:bs:cd=\EJ:ce=\EK:cl=\EE:cm=\EY%+ %+ :co#80:dc=\EN:\ - :dl=1*\EM:do=\EB:ei=\EO:ho=\EH:im=\E@:li#24:mi:nd=\EC:as=\EF:ae=\EG:\ - :ms:pt:sr=\EI:se=\Eq:so=\Ep:up=\EA:vs=\Ex4:ve=\Ey4:\ - :kb=^h:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\EH:kn#8:\ - :k1=\ES:k2=\ET:k3=\EU:k4=\EV:k5=\EW:\ - :l6=blue:l7=red:l8=white:k6=\EP:k7=\EQ:k8=\ER: -ke|e19|winston edmond special:vb=\Eg\Eh:tc=h19: -ku|h19u|heathkit with underscore cursor:vs@:ve@:tc=h19b: -Ma|aa|annarbor|ann arbor:\ - :cm=^O%r%B%.%>^S^L%+@:co#80:li#40:bs:cl=2^L:up=^N:nd=^_:ho=^K:am:\ - :kb=^^:kd=^J:ku=^N:kl=^H:kr=^_:kh=^K:ma=^_ ^N^P: -# The A manufacturer represents Diablo, DTC, Xerox, Qume, and other Daisy -# wheel terminals until such time as termcap distinguishes between them -# enough to justify separate codes. -# 1620 uses all 132 columns, 1640 sets left margin to 8 and uses snazzy -# binary tabset file. Both should work on both terminals. -A6|1620|450|diablo 1620:\ - :if=/usr/lib/tabset/std:\ - :kb=^H:bs:co#132:ff=^L:hc:hu=\EU:hd=\ED:os:pt:up=\E\n: -A7|1640|diablo 1640:\ - :co#124:if=/usr/lib/tabset/diablo:tc=1620: -Ad|dtc300s|300|300s|gsi|dtc|dtc 300s:\ - :if=/usr/lib/tabset/std:\ - :kb=^h:bs:co#132:ff=^L:hc:hu=\EH:hd=\Eh:os:pt:up=^Z: -Ag|gsi:bs:co#132:hc:hd=\Eh:hu=\EH:os:pt:up=^Z: -Aj|aj830|aj832|aj|anderson jacobson:\ - :bs:hc:hd=\E9:hu=\E8:os:pl:up=\E7: -Aq|qume5|qume|Qume Sprint 5:\ - :if=/usr/lib/tabset/std:\ - :kb=^h:bs:co#80:ff=^L:hc:hu=\EH:hd=\Eh:os:pt:up=^Z: -Ax|x1720|xerox 1720:co#132:bs:ff=^L:hc:os:pt:if=/usr/lib/tabset/xerox1720 -Ca|cdc456|cdc:\ - :li#24:co#80:cl=^Y^X:nd=^L:up=^Z:bs:\ - :cm=\E1%+ %+ :ho=^Y:al=\E\114:dl=\E\112:ce=^V:cd=^X:am: -Cc|cdc456tst:\ - :li#24:co#80:cl=^y^x:bs:cm=\E1%+ %+ :am: -D0|dm1520|1520|datamedia 1520:\ - :am:bs:cd=^K:ce=^]:cl=^L:cm=^^%r%+ %.:co#80:ho=^Y:\ - :ku=^_:kd=^J:kl=^H:kr=^\:kh=^Y:\ - :li#24:nd=^\:up=^_:xn:ma=^\ ^_^P^YH:pt: -D1|dm1521|1521|datamedia 1521:\ - :am:bs:cd=^K:ce=^]:cl=^L:cm=^^%r%+ %.:co#80:ho=^Y:\ - :ku=^_:kd=^J:kl=^H:kr=^\:kh=^Y:\ - :li#24:nd=^\:up=^_:xn:ma=^\ ^_^P^YH:pt: -D2|dm2500|datamedia2500|2500|datamedia 2500:\ - :al=15^P\n^X^]^X^]:bs:ce=^W:cl=^^^^\177:cm=^L%r%n%.%.:co#80:\ - :dc=10*\b:dl=10*^P^Z^X^]:dm=^P:ed=^X^]:ei=10\377\377^X^]:ho=^B:ic10*^\:\ - :im=^P:li#24:nc:nd=^\:pc=\377:so=^N:se=^X^]:up=^Z: -D3|dm3025|datamedia 3025a:is=\EQ\EU\EV:\ - :al=130\EP\n\EQ:bs:cd=2\EJ:ce=\EK:cl=2\EM:cm=\EY%r%+ %+ :\ - :co#80:dc=6\b:dl=130\EP\EA\EQ:dm=\EP:ed=\EQ:ei=\EQ:ho=\EH:\ - :im=\EP:ip=6:li#24:nd=\EC:pt:so=\EOA:se=\EO@:up=\EA: -D4|3045|dm3045|datamedia 3045a:is=\EU\EV:\ - :am:bs:cd=2\EJ:ce=\EK:cl=2\EM:cm=\EY%r%+ %+ :co#80:\ - :dc=6\EB:dm=:ed=:ei=\EP:ho=\EH:ic=:im=\EP:ip=6:\ - :k0=\Ey\r:k1=\Ep\r:k2=\Eq\r:k3=\Er\r:k4=\Es\r:\ - :k5=\Et\r:k6=\Eu\r:k7=\Ev\r:k8=\Ew\r:k9=\Ex\r:\ - :kh=\EH:ku=\EA:kr=\EC:li#24:nd=\EC:pc=\177:pt:eo:ul:up=\EA:xn: -D5|dt80|dmdt80|dm80|datamedia dt80/1:\ - :is=\E<\E[2J\E[H\E[?1;3;5;6;9l\E[?7;8h:\ - :am:bs:cd=\E[J:co#80:li#24:ce=\E[K:cl=\E[2J\E[H:\ - :cm=%i\E[%d;%dH:ho=\E[H:nd=\E[C:\ - :so=\E[7m:se=\E[m:\ - :up=\E[A:us=\E[4m:ue=\E[m:\ - :vb=\E[?5h\E[?5l:\ - :vs=\E[1;2;3;4q\E[?4l:ve=\E[0q\E?4h:\ - :kd=\E[B:kl=\E[D:kr=\E[C:ku=\E[A:\ - :sr=\EM:\ - :k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS: -D6|dt80132|dmdt80132|datamedia dt80/1 in 132 char mode:\ - :bs:cd=20^[[0J:co#132:ce=20^[[0K:kd=^[[B:kl=^[[D:kr=^[[C:ku=^[[A:\ - :li#24:cm=5^[[%i%d;%dH:cl=50^[[H^[[2J:nd=^[[C:up=5^[[A: -ED|delta|dd5000|delta data 5000:\ - :am:bs:cl=^NR:cm=^O%D%+9%D%+9:co#80:li#27:ho=^NQ:nc:nd=^Y:\ - :up=^Z:ce=^NU:dc=^NV:ma=^K^J^Z^P^Y :xr: -# Note: the h1552 appears to be the first Hazeltine terminal which -# is not braindamaged. It has tildes and backprimes and everything! -# Be sure the auto lf/cr switch is set to cr. -H2|h1552|hazeltine 1552:\ - :al=\EE:dl=\EO:f1=\EP:l1=blue:f2=\EQ:l2=red:f3=\ER:l3=green:tc=vt52: -H3|h1552rv|hazeltine 1552 reverse video:\ - :so=\ES:se=\ET:tc=h1552: -H5|h1500|hazeltine 1500:\ - :al=40~^Z:am:bs:cd=10~^X:ce=~^O:cl=~^\:cm=~^Q%r%.%.:co#80:\ - :dl=40~^S:do=~^K:hz:li#24:nd=^P:.se=~^_:.so=~^Y:up=~^L: -H6|h1510|hazeltine 1510:\ - :al=\E^Z:am:bs:cd=\E^X:ce=\E^O:cl=\E^\:cm=\E^Q%r%.%.:co#80:\ - :dl=\E^S:do=\E^K:hz:li#24:nd=^P:.se=\E^_:.so=\E^Y:up=\E^L: -H8|h1520|hazeltine 1520:\ - :al=~^Z:am:bs:cd=~^X:ce=~^O:cl=~\034:cm=~^Q%r%.%.\200:co#80:\ - :dl=~^S:do=~^K:hz:li#24:nd=^P:se=~^Y:so=~\037:up=~^L:ho=~^R: -# Note: h2000 won't work because of a clash between upper case and ~'s. -H7|h2000|hazeltine 2000:\ - :al=6~^z:am:bs:cl=6~^\:cm=~^q%r%.%.:co#74:\ - :dl=6~^s:ho=~^r:li#27:nc:pc=\177: -# One of these should go in the misc category, IBM and ISC can't -# both have I. I will wait to see who comes out with more terminals. -I8|8001|ISC8001:al=\EU:am:bc=^Z:cl=3*^L:cm=^C%r%.%.:co#80:\ - :cd=\EQ:dm=\EQ:ed=\EF:\ - :dc=\177:dl=\EV:ei=\EF:im=\EQ:li#40:nd=1^Y:ta=8\t:\ - :up=^\:ho=1^H:pc=^@: -It|intext|ISC modified owl 1200:\ - :al=5.5*\020:am:bc=\037:bs:cd=5.5*\026J:cl=132\014:\ - :cm=\017%+ %+ :co#80:dc=5.5*\022:dl=5.5*\021:\ - :ei=\026\074:im=\026\073:ip=5.5*:in:li#24:nd=\036:up=\034:\ - :ma=^K^P^R^L^L :kl=^H:kd=^J:kr=^L:ku=^K: -I9|ibm|ibm3101|3101|i3101|IBM 3101-10:\ - :if=/usr/lib/tabset/3101:\ - :am:bs:cl=^[K:li#24:co#80:nd=^[C:up=^[A:cd=^[J:ce=^[I:\ - :kd=\EB:kl=\ED:kr=\EC:ku=\EA:ho=^[H:cm=\EY%+\40%+\40: -L3|digilog|333|digilog 333:bs:co#80:ce=\030:ho=^n:li#16:nd=^i:up=^o: -MA|ampex|d80|dialogue|dialogue80|ampex dialogue 80:\ - :am:bs:pt:if=/usr/lib/tabset/stdcrt:cl=\E*:cm=\E=%+ %+ :\ - :al=\EE:bt=\EI:ic=\EQ:im=:ei=:dl=\ER:dc=\EW:\ - :ce=\Et:cd=\Ey:so=\Ej:se=\Ek:li#24:co#80:nd=^L:up=^K: -MB|aaadb|ann arbor ambassador 48/destructive backspace:\ - :is=\E[48;0;0;48p\E[H\E[J\E[>30h\E[1Q\E[m:bs@:\ - :vs=\E[>30l:ve=\E[>30h:tc=aaa: -MC|compucolor|compucolorII:\ - :pt:am:cm=%r^C%.%.:bc=^Z:li#32:co#64:\ - :cl=^L:ho=^H:nd=^Y:up=^\: -MD|d132|datagraphix|datagraphix 132a:\ - :co#80:li#30:cl=^l:ho=\Et:da:db:sf=\Ev:sr=\Ew:\ - :up=\Ek:nd=\El:vs=\ex:ve=\Em\En:\ - :al=\E3:ic=\E5:dc=\E6:in:ic=\E5: -MS|soroc|Soroc 120:\ - :cd=\EY:ce=\ET:cl=2\E*:ma=^K^P^R^L^L :\ - :kl=^H:ku=^K:kr=^L:kd=^J:tc=adm3a: -# Needs function keys added. Also can't use 60 line mode because it needs -# too much nl delay - can fix for nl but not out of vi. -# The cl delay is sufficient, but a smaller one could do. -# This entry is merged from Mike O'Brien@Rand and Howard Katseff at -# Bell Labs, and is untested. -Mb|aaa|ambas|ambassador|ann arbor ambassador/48 lines:\ - :al=\E[L:am:bs:\ - :cd=\E[0J:ce=\E[0K:cl=400\E[;H\E[0J:cm=\E[%i%d;%dH:co#80:\ - :da:db:dc=\E[4h\E[1Q\E[P\E[4l\E[0Q:dc=\E[P:dl=\E[M:dm=\E[1Q:\ - :ed=\E[0Q:ei=\E[0Q:ho=\E[;H:ic=\E[@:if=/usr/lib/tabset/aa:im=\E[1Q:\ - :is=\E[48;0;0;48p\E[H\E[J\E[1Q\E[m:li#48:mi:\ - :nd=\E[C:nl=\ED:pt:sf=\E[S:sr=\E[T:se=\E[m:so=\E[7m:up=\E[A: -Md|datapoint|dp3|dp3360|datapoint 3360:\ - :am:bs:cd^_:ce=^^:cl=^]^_:co#82:ho=^]:li#25:nd=^x:up=^z: -Mg|dg|dg6053|data general 6053:\ - ca:am:bs:cm=^P%r%.%.:cl=^L:ho=^H:nd=^S\ - up=^W:ce=^K:co#80:li#24: -Mi|cdi|cdi1203:am:bs:hc:os:co#80:cD#200: -Mk|teletec|tec|Teletec Datascreen:\ - :am:bs:co#80:cl=^l:ho=^^:li#24:nd=^_:up=^k: -# ^S is an arrow key! Boy is this guy in for a surprise on v7! -Ml|sol:\ - :am:bs:cm=\E^1%.\E^2%.:cl=^K:ho=^N:co#64:li#16:nd=^S:up=^W:\ - :kl=^A:kr=^S:ku=^W:kd=^Z:ma=^A^H^S ^W^P^Z^N: -Mo|omron|Omron 8025AG:\ - :al=\EL:am:bs:cd=\ER:co#80:ce=\EK:cl=\EJ:da:db:dc=\EP:dl=\EM:\ - :ho=\EH:li#24:nd=\EC:se=\E4:sf=\ES:so=\Ef:sr=\ET:up=\EA:ve=:vs=\EN: -Mp|plasma|plasma panel:am:bs:cl=^L:co#85:ho=^^:li#45:nd=\030:up=\026: -Ms|swtp|ct82|southwest technical products ct82:\ - :am:bs:bc=^d:al=^\^y:cd=^v:ce=^F:cl=^L:cm=%r^k%.%.:co#82:li#20:\ - :dl=^z:nd=^s:up=^a:so=^^^v:se=^^^F:dc=^\^h:ic=^\^x:ho=^p:\ - :ei=:sf=^n:sr=^o:ll=^c:im=:\ - :is=^\^r^^^s^^^d^]^w^i^s^^^]^^^o^]^w^r^i: -Mt|terak|Terak emulating Datamedia 1520:tc=dm1520: -My|mdl110|cybernex mdl-110:cm=^P%+ %+ :co#80:li#24:am:cl=70^X:bs:\ - :nd=^U:up=^Z:ho=^Y:ce=145^N@^V:cd=145^NA^W:al=65^NA^N^]:\ - :dl=40^NA^N^^:im=:\ - :ei=:ic=3.5^NA^]:dm:ed:dc=3.5^NA^^:so=^NF:se=^NG:ta=43\t:\ - :ma=^Z^P:cd=6^N@^V -Mz|zen30|z30|zentec 30:\ - :mi:co#80:li#24:ma=^L ^R^L^K^P:ul:\ - :al=1.5*\EE:bs:ce=1.0*\ET:cm=\E=%+ %+ :cl=\E*:\ - :ho=^^:nd=^L:se=\EG0;so=\EG6:up=^K:im=\Eq:ei=\Er:\ - :am:dc=\EW:dl=1.5*\ER:cd=\EY: -T3|33|tty33|tty|model 33 teletype:\ - :co#72:hc:os: -T4|43|tty43|model 43 teletype:\ - :kb=^h:am:bs:hc:os:co#132: -T7|37|tty37|model 37 teletype:\ - :bs:hc:hu=\E8:hd=\E9:up=\E7:os: -# The Visual 200 beeps when you type a character in insert mode. -# This is a horribly obnoxious misfeature, and some of the entries -# below try to get around the problem by ignoring the feature or -# turning it off when inputting a character. They are said not to -# work well at 300 baud. (You could always cut the wire to the bell!) -V2|vi200|v200|visual 200 with function keys:\ - :al=\EL:am:bs:cd=\Ey:ce=4*\Ex:cl=\Ev:\ - :cm=\EY%+ %+ :co#80:dc=4*\EO:dl=4*\EM:ho=\EH:\ - :im=:ei=:ic=\Ei \b\Ej:\ - :is=\E3\Eb\Ej\E\\\El\EG\Ed\Ek:\ - :k0=\EP:k1=\EQ:k2=\ER:k3=\E :k4=\E!:k5=\E":k6=\E#:\ - :k7=\E$:k8=\E%:k9=\E&:kl=\ED:kr=\EC:ku=\EA:kd=\EB:kh=\EH:\ - :li#24:nd=\EC:pt:sr=\EI:up=\EA:vs=\Ed:ve=\Ec: -VR|vi200rvic|visual 200 reverse video using insert char:\ - :ei=\Ej:im=\Ei:ic@:tc=vi200rv: -# The older Visuals didn't come with function keys. This entry uses -# ks and ke so that the keypad keys can be used as function keys. -# If your version of vi doesn't support function keys you may want -# to use V2. -Vf|vi200f|visual|visual 200 no function keys:\ - :al=\EL:am:bs:cd=\Ey:ce=4*\Ex:cl=\Ev:\ - :cm=\EY%+ %+ :co#80:dc=4*\EO:dl=4*\EM:ho=\EH:\ - :im=:ei=:ic=\Ei \b\Ej:\ - :is=\E3\Eb\Ej\E\\\El\EG\Ed\Ek:ks=\E=:ke=\E>:\ - :k0=\E?p:k1=\E?q:k2=\E?r:k3=\E?s:k4=\E?t:k5=\E?u:k6=\E?v:\ - :k7=\E?w:k8=\E?x:k9=\E?y:kl=\ED:kr=\EC:ku=\EA:kd=\EB:kh=\EH:\ - :li#24:nd=\EC:pt:sr=\EI:up=\EA:vs=\Ed:ve=\Ec: -Vr|vi200rv|visual 200 reverse video:\ - :so=\E4:se=\E3:sr@:vs@:ve@:tc=vi200: -Vt|vi200ic|visual 200 using insert char:\ - :ei=\Ej:im=\Ei:ic@:tc=vi200: -Xa|tek4012|4012|tektronix 4012:\ - :is=\E^O:bs:cl=1000\E^L:co#75:ns:li#35:os: -Xb|tek4013|4013|tektronix 4013:\ - :as=\E^N:ae=\E^O:tc=4012: -Xc|tek4014|4014|tektronix 4014:\ - :is=\E^O\E9:co#81:li#38:dF#1000:tc=tek4012: -Xd|tek4015|4015|tektronix 4015:\ - :as=\E^N:ae=\E^O:tc=4014: -Xe|tek4014sm|4014sm|tektronix 4014 in small font:\ - :is=\E^O\E\072:co#121:li#58:tc=tek4014: -Xf|tek4015sm|4015sm|tektronix 4015 in small font:\ - :as=\E^N:ae=\E^O:tc=4014sm: -# I think the 1000UP is supposed to be so expensive it never happens. -X4|tek4023|4023|tektronix 4023:\ - :so=^_P:se=^_@:cm=\034%r%+ %+ :nd=\t:bs:cl=4\E^L:co#80:li#24:am:\ - :up=1000UP: -# Can't use cursor motion because it's memory relative, and because -# it only works in the workspace, not the monitor. Same for home. -# Likewise, standout only works in the workspace. -X5|tek|4025|4027|4024|tek4025|tek4027|tek4024|4025cu|4027cu|tektronix 4024/4025/4027:\ - :is=\41com 31\r\n^_sto 9,17,25,33,41,49,57,65,73\r:\ - :ks=^_lea p4 /h/\r^_lea p8 /k/\r^_lea p6 / /\r^_lea p2 /j/\r^_lea f5 /H/\r:\ - :ke=^_lea p2\r^_lea p4\r^_lea p6\r^_lea p8\r^_lea f5\r:\ - :am:bs:da:db:pt:li#34:co#80:cl=^_era\r\n\n:up=^K:nd=^_rig\r:\ - :al=145^_up\r^_ili\r:dl=^_dli\r:\ - :dc=^_dch\r:im=^_ich\r:ei=^F\n^K:nl=^F\n:\ - :ce=^_dch 80\r:cd=^_dli 50\r:CC=^_: -X7|4025-17|4027-17|tek 4025 17 line window:li#17:tc=4025: -X8|4025-17ws|4027-17ws|tek 4025 17 line window in workspace:\ - :is=\41com 31\r\n^_sto 9,17,25,33,41,49,57,65,73\r^_wor 17\r^_mon 17\r:\ - :ti=^_wor h\r:te=^_mon h\r:so=^_att e\r:se=^_att s\r:tc=4025-17: -Xe|4025ex|4027ex|tek 4025 w/!:ti=\41com 31\r:te=^_com 33\r:\ - :is=^_com 33\r\n\41sto 9,17,25,33,41,49,57,65,73\r:tc=4025: -# Regent: lowest common denominator, works on all regents. -a0|regent|adds regent series:\ - :am:bs:cl=^L:cm=^K%+ ^P%B%.:co#80:ho=^A:li#24:ll=^A^Z:nd=^F:up=^Z: -# Regent 100 has a bug where if computer sends escape when user is holding -# down shift key it gets confused, so we avoid escape. -a1|regent100|adds regent 100:\ - :cm=^K%+ ^P%B%.:k1=^B1\r:k2=^B2\r:k3=^B3\r:k4=^B4\r:\ - :k5=^B5\r:k6=^B6\r:k7=^B7\r:k8=^B8\r:\ - :kh=^A:kl=^U:kr=^F:ku=^Z:kd=^J:tc=regent: -# Regent 20, untested -a2|regent20|adds regent 20:\ - :cd=\Ek:ce=\EK:cm=\EY%+ %+ :tc=regent: -a3|regent25|adds regent 25:\ - :k0=^B0\r:k1=^B1\r:k2=^B2\r:k3=^B3\r:k4=^B4\r:\ - :k5=^B5\r:k6=^B6\r:k7=^B7\r:k8=^B8\r:k9=^B9\r:\ - :kh=^A:kl=^U:kr=^F:ku=^Z:kd=^J:tc=regent20: -# Regent 40: untested -a4|regent40|adds regent 40:\ - :al=\EM:dl=\El:is=\EB:se=\E0@:so=\EOP:ue=\EO@:us=\E0`:vb=\ED\Ed:\ - :tc=regent25: -# If you have standout problem with regent 200, try so=\ER\EOP:se=\E0@\EV: -a6|regent60|regent200|adds Regent 60:\ - :dc=\EE:ei=\EF:im=\EF:is=\EV\EB:ko=dc,im,ei:tc=regent40: -a7|regent60na|regent 60 w/no arrow keys:\ - kl@:kr@:ku@:kd@:tc=regent60: -# Note: if return acts weird on a980, check internal switch #2 -# on the top chip on the CONTROL pc board. -ac|a980|adds consul 980:\ - :al=13\E^N:am:bs:cl=^L\200^K@:cm=^K%+@\E^E%2:co#80:dl=13\E^O:\ - :k0=\E0:k1=\E1:k2=\E2:k3=\E3:k4=\E4:k5=\E5:k6=\E6:k7=\E7:k8=\E8:k9=\E9:\ - :li#24:nd=\E^E01:so=^Y^^^N:se=^O:up=9: -b2|sb2|sb3|fixed superbee:xb@:tc=superbee: -bh|bh3m|beehiveIIIm:if=/usr/lib/tabset/beehive:\ - :al=160^S:am:bs:cd=^R:ce=^P:cl=^E^R:co#80:dl=300^Q:ho=^E:li#20:ll=^E^K:\ - :nd=^L:pt:se= ^_:so=^] :up=^K: -# This loses on lines > 80 chars long, use at your own risk -bi|superbeeic|super bee with insert char:\ - :ic=:im=\EQ:ei=\ER:tc=superbee: -bm|microb|microbee|micro bee series:\ - :am:bs:cd=\EJ:ce=\EK:cl=\EE:co#80:cm=\EF%+ %+ :\ - :k1=\Ep:k2=\Eq:k3=\Er:k4=\Es:k5=\Et:k6=\Eu:k7=\Ev:k8=\Ew:k9=\Ex:\ - :kd=\EB:kh=\EH:kl=\ED:kr=\EC:ku=\EA:\ - :li#24:nd=\EC:pt:se=\Ed@ :so= \EdP:ue=\Ed@:up=\EA:us=\Ed`: -# Superbee - f1=escape, f2=^C. -# Note: there are at least 3 kinds of superbees in the world. The sb1 -# holds onto escapes and botches ^C's. The sb2 is the best of the 3. -# The sb3 puts garbage on the bottom of the screen when you scroll with -# the switch in the back set to CRLF instead of AEP. This description -# is tested on the sb2 but should work on all with either switch setting. -# The f1/f2 business is for the sb1 and the :xb: can be taken out for -# the other two if you want to try to hit that tiny escape key. -# This description is tricky: being able to use cm depends on there being -# 2048 bytes of memory and the hairy nl string. -bs|sb1|superbee|superb|beehive super bee:if=/usr/lib/tabset/stdcrt:is=\EE:\ - :am:bs:cd=3\EJ:ce=3\EK:cl=3\EH\EJ:co#80:cm=\EF%r%3%3:cr=1000\r:\ - :dC#10:da:db:xb:dc=3\EP:dl=100\EM:so=\E_1:se=\E_0:\ - :li#25:nl=\n\200\200\200\n\200\200\200\EA\EK\200\200\200\ET\ET:\ - :nd=\EC:pt:up=\EA:ho=\EH:ve=\n:\ - :k1=\Ep:k2=\Eq:k3=\Er:k4=\Es:k5=\Et:k6=\Eu:k7=\Ev:k8=\Ew:\ - :kd=\EB:kh=\EH:kl=\ED:kr=\EC:ku=\EA: -d2|gt42|dec gt42:\ - :bs:co#72:ns:li#40:os: -d4|gt40|dec gt40:\ - :bs:co#72:ns:li#30:os: -d5|vt50|dec vt50:\ - :bs:cd=\EJ:ce=\EK:cl=\EH\EJ:co#80:li#12:nd=\EC:pt:up=\EA: -dI|dw1|decwriter I:\ - :bs:co#72:hc:os: -dh|vt50h|dec vt50h:\ - :bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#80:li#12:nd=\EC:\ - :pt:sr=\EI:up=\EA: -# -# ds|vt100s|vt-100s|pt100s|pt-100s|dec vt100 132 cols 14 lines:\ -# :li#14:tc=vt100w: -# -dt|vt100w|vt-100w|pt100w|pt-100w|dec vt100 132 cols:\ - :co#128:li#24:is=\E>\E[?3h\E[?4l\E[?5l\E[?7h\E[?8h:tc=vt100: -dv|vt52|dec vt52:\ - :bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#80:li#24:nd=\EC:\ - :pt:sr=\EI:up=\EA:ku=\EA:kd=\EB:kr=\EC:kl=\ED: -dw|dw2|dw3|dw4|decwriter II:\ - :kb=^h:bs:co#132:hc:os: -e1|ep48|ep4080|execuport 4080:am:bs:os:co#80:hu=\036:hd=\034: -e2|ep40|ep4000|execuport 4000:am:bs:os:co#136:hu=\036:hd=\034: -g2|1200|tn1200|terminet 1200:\ - :co#120:hc:os: -g3|300|tn300|terminet 300:\ - :co#120:hc:os: -# Note: no "ho" on HP's since that homes to top of memory, not screen. -# Due to severe braindamage, the only way to get the arrow keys to -# transmit anything at all is to turn on the function key labels -# (f1-f8) with ks, and even then the poor user has to hold down shift! -# The default 2621 turns off the labels except when it has to to enable -# the function keys. If your installation prefers labels on all the time, -# or off all the time (at the "expense" of the function keys) move the -# 2621nl or 2621wl labels to the front using reorder. -# 2621k45: untested -h2|2621|hp2621|hp2621a|hp2621p|2621|2621a|2621p|hp 2621:\ - :is=\E&j@\r\E3\r:bt=\Ei:cm=\E&a%r%dc%dY:dc=2\EP:ip=2:\ - :kh=\Ep\r:ku=\Et\r:kl=\Eu\r:kr=\Ev\r:kd=\Ew\r:\ - :kn#8:k1=\Ep\r:k2=\Eq\r:k3=\Er\r:k4=\Es\r:k5=\Et\r:k6=\Eu\r:k7=\Ev\r:\ - :k8=\Ew\r:ks=\E&jB:ke=\E&j@:ta=2^I:tc=hp: -h3|2621k45|hp2621k45|k45|hp 2621 with 45 keyboard:\ - :kb=^H:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\Eh:ks=\E&s1A:ke=\E&s0A:tc=2621: -h4|hp|hp2645|2645|hp 264x series:\ - :if=/usr/lib/tabset/stdcrt:\ - :al=\EL:am:bs:cd=\EJ:ce=\EK:ch=\E&a%dC:cl=\EH\EJ:cm=6\E&a%r%dc%dY:\ - :co#80:cv=\E&a%dY:da:db:dc=\EP:dl=\EM:ei=\ER:im=\EQ:\ - :kb=^H:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\Eh:ks=\E&s1A:ke=\E&s0A:\ - :li#24:mi:ml=\El:mu=\Em:nd=\EC:pt:se=\E&d@:so=\E&dJ:\ - :us=\E&dD:ue=\E&d@:up=\EA:xs: -h6|hp2626|hp2626a|hp2626p|2626|2626a|2626p|hp 2626:\ - :is=\E&j@\r\E3\r:if=/usr/lib/tabset/stdcrt:\ - :al=\EL:am:bs:bt=\Ei:cd=\EJ:ce=\EK:cl=\EH\EJ:\ - :cm=\E&a%r%dc%dY:co#80:da:db:dc=2\EP:dl=\EM:ei=\ER:\ - :im=\EQ:ip=2:li#24:mi:nd=\EC:pt:se=\E&d@:so=\E&dB:up=\EA:\ - :kh=\Eh:ku=\EA:kl=\ED:kr=\EC:kd=\EB:\ - :ma=j^Jk^P^K^Pl :sf=\ES:\ - :ta=2^I:xs: -# cD a pain - only screw up at 9600 baud. -h8|hp2648|hp2648a|2648a|2648|HP 2648a graphics terminal:\ - :cl=50\EH\EJ:cm=20\E&a%r%dc%dY:dc=7\EP:ip#5:is=130\Eg:tc=2645: -# 2640a doesn't have the Y cursor addressing feature, and C is memory relative -# instead of screen relative, as we need . -ha|2640|hp2640a|2640a|hp 2640a:cm@:ks@:ke@:tc=2645: -hb|2640b|hp2640b|2644a|hp2644a|hp 264x series:ks@:ke@:tc=2645: -# 2621 using all 48 lines of memory, only 24 visible at any time. Untested. -hb|big2621|48 line 2621:li#48:ho=\EH:cm=\E&a%r%dc%dR:tc=2621: -hn|2621nl|hp2621nl|2621|hp 2621 with no labels:ks@:ke@:kh@:ku@:kl@:kr@:kd@:tc=hp2621: -hw|2621wl|hp2621wl|2621|hp 2621 with labels:is=\E&jA\r\E3\r:ke=\E&jA:tc=hp2621: -# Infoton is now called General Terminal Corp. or some such thing. -# gt100 sounds like something DEC would come out with. Lets hope they don't. -i1|i100|gt100|gt100a|General Terminal 100A (formerly Infoton 100):\ - :cl=^L:cd=\EJ:ce=\EK:li#24:co#80:\ - :al=\EL:dl=\EM:up=\EA:nd=\EC:ho=\EH:cm=\Ef%r%+ %+ :vb=\Eb\Ea:am:bs:\ - :so=\Eb:se=\Ea: -i4|i400|400|infoton 400:\ - :if=/usr/lib/tabset/infoton_tabs:\ - :al=\E[L:am:bs:ce=\E[N:cl=\E[2J:cm=%i\E[%3;%3H:co#80:dl=\E[M:li#25:\ - :nd=\E[C:up=\E[A:im=\E[4h\E[2Q:ei=\E[4l\E[0Q:\ - :dc=\E[4h\E[2Q\E[P\E[4l\E[0Q: -ia|addrinfo:\ - :li#24:co#80:cl=^L:ho=^H:nd=^Y:cd=^K:\ - :up=^\:am:bc=^Z:cm=\037%+\377%+\377:ll=^H^\: -ik|infotonKAS:\ - :am:bc=^Z:cd=^K:cl=^L:co#80:li#24:nd=^Y:up=^\:ll=^H^\: -l1|adm31|31|lsi adm31:is=\Eu\E0:\ - :al=\EE:am:bs:ce=\ET:cm=\E=%+ %+ :cl=\E*:co#80:dc=\EW:dl=\ER:\ - :ei=\Er:ho=^^:im=\Eq:li#24:mi:nd=^L:se=\EG0:so=\EG4:up=^K:\ - :kl=^H:kd=^J:ku=^K:kr=^L:ma=^K^P^L : -l2|adm2|lsi adm2:\ - :al=\EE:am:bs:cd=\EY:ce=\ET:cl=\E;:cm=\E=%+ %+ :co#80:dc=\EW:dl=\ER:\ - :ei=:ho=^^:ic=\EQ:im=:kd=^J:kh=^^:kl=^H:kr=^L:ku=^K:li#24:nd=^L:up=^K: -l3|adm3|3|lsi adm3:\ - :am:bs:cl=^Z:li#24:ma=^K^P:co#80: -l4|adm42|42|lsi adm42:vs=\EC\E3 \E3(:\ - :al=270\EE:am:bs:cd=\EY:ce=\ET:cl=\E;:cm=\E=%+ %+ :co#80:\ - :dc=\EW:dl=\ER:ei=\Er:im=\Eq:ip=6*:li#24:\ - :bt=\EI:nd=^L:se=\EG0:so=\EG4:ta=\t:up=^k:\ - :ma=^K^P:pc=\177: -la|adm3a|3a|lsi adm3a:\ - :am:bs:cm=\E=%+ %+ :cl=1^Z:co#80:ho=^^:li#24:ma=^K^P:nd=^L:up=^K: -lb|adm3a+|3a+:kl=^H:kd=^J:ku=^K:kr=^L:tc=adm3a: -# These mime1 entries refer to the Microterm Mime I or Mime II. -# The default mime is assumed to be in enhanced act iv mode. -m3|mime3a|mime1 emulating 3a:\ - :am@:ma=^X ^K^J^Z^P:ku=^Z:kd=^K:kl=^H:kr=^X:tc=adm3a: -m4|microterm|act4|microterm act iv:\ - :am:bs:cd=^_:ce=^^:cl=^L:cm=^T%.%.:co#80:li#24:nd=^X:up=^Z:ho=^]: -# The padding on sr and ta for act5 and mime is a guess and not final. -m5|microterm5|act5|microterm act v:\ - :uc=\EA:pt:ta=2^I:sr=3\EH:ku=^Z:kd=^K:kl=^H:kr=^X:ma=^Z^P^Xl^Kj:tc=act4: -# act5s is not tested and said not to work. -mS|act5s|skinny act5:ti=\EP:te=\EQ:li#48:co#39:tc=act5: -# Mimes using brightness for standout. Half bright is really dim unless -# you turn up the brightness so far that lines show up on the screen. -# uc is disabled to get around a curses bug, and should be put back in someday. -mf|mimefb|full bright mime1:so=^Y:se=^S:uc@:is=^S\E:tc=mime: -mh|mimehb|half bright mime1:so=^S:se=^Y:uc@:is=^Y\E:tc=mime: -mm|mime|mime1|mime2|mimei|mimeii|microterm mime1:\ - :al=80^A:am:bs:cd=^_:ce=^^:cl=\035^C:cm=^T%+^X%> 0%+P:co#80:\ - :dl=80^W:ta=2^I:li#24:nd=^X:pt:uc=^U:up=^z:ho=\035:do=^K:is=^S\E:\ - :ma=^X ^K^J^Z^P:ku=^Z:kd=^K:kl=^H:kr=^X:sr=3^R: -# These termcaps (for mime 2a) put the terminal in low intensity mode -# since high intensity mode is so obnoxious. -ms|mime2as|microterm mime2a (emulating an enhanced soroc iq120):\ - :al=20*^A:am:bs:cd=20*\EJ:ce=\EK:cl=\EL:cm=\E=%+ %+ :co#80:dc=\ED:\ - :dl=20*^W:kl=^H:kr=^L:ku=^K:kd=^J:ho=^^:is=\E):sr=\EI\ - :im=\EE:ei=^Z:ip=2:li#24:nd=^L:so=\E\072:se=\E;:up=\EI:\ - :us=\E6:ue=\E7: -# This is the preferred mode (but ^X can't be used as a kill character) -mv|mime2a|mime2av|microterm mime2a (emulating an enhanced vt52):\ - :al=20*^A:bs:cd=20*\EQ:co#80:ce=\EP:cl=\EL:cm=\EY%+ %+ :is=^Y\ - :dc=^N:dl=20*^W:ip=2:ei=^Z:ho=\EH:im=^O:kd=\EB:kl=\ED:kr=\EC:ku=\EA:\ - :li#24:nd=\EC:pt:se=\E9:so=\E8:up=\EA:sr=\EA:us=\E4:ue=\E5: -mx|mime3ax|mime1 emulating enhanced 3a:\ - :al=80^A:dl=80^W:pt:ce=^X:cd=^_:tc=mime3a: -n2|spin|nec spinwriter 5525|spinwriter:\ - :bs:co#136:hc:hd=\EU:hu=\ED:os:pt:so=\EA:se=\EB:\ - :if=/usr/lib/tabset/spinwriter: -pf|fox|perkin elmer 1100:if=/usr/lib/tabset/stdcrt:\ - :am:bs:cd=5.5*\EJ:ce=\EI:cl=132\EH\EJ:co#80:ho=\EH:li#24:\ - :ll=\EH\EA:nd=\EC:cm=\EX%+ \EY%+ :up=\EA:vb=^P^B^P^C: -po|owl|perkin elmer 1200:if=/usr/lib/tabset/stdcrt:\ - :al=5.5*\EL:am:bs:cd=5.5*\EJ:ce=5.5\EI:cl=132\EH\EJ:ho=\EH:ll=\EH\EA:\ - :cm=\EX%+ \EY%+ :co#80:dc=5.5*\EO:dl=5.5*\EM:ei=:ic=\EN:im=:ip=5.5*:\ - :kb=^h:in:li#24:nd=\EC:up=\EA:se?=\E!\200:so?=\E!^H:vb=^P^B^P^C:\ - :k1=\ERA:k2=\ERB:k3=\ERC:k4=\ERD:k5=\ERE:k6=\ERF:\ - :k7=\ERG:k8=\ERH:k9=\ERI:k0=\ERJ: -# -# qB|bc|bill croft homebrew:\ -# :am:bs:cm=\E=%+ %+ :cl=^Z:co#96:ho=^^:li#72:\ -# :nd=^L:up=^K:vb=: -# -#NOTE: bg can scroll, it just would rather not (ns) - rwells 3/13/81. -qB|bg|bg2.0|bgn|BBN BitGraph Terminal (no init):\ - :al=2*\E[L:bs:cd=150\E[J:ce=2\E[K:cl=150\E[H\E[J:cm=%i\E[%d;%dH:\ - :co#85:cs=\E[%i%d;%dr:dl=2*\E[M:\ - :k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:\ - :kd=\E[B:ke=\E>:kl=\E[D:kr=\E[C:ks=\E=:ku=\E[A:\ - :l1=PF1:l2=PF2:l3=PF3:l4=PF4:\ - :li#64:nd=\E[C:ns:pt:se=\E[0m:so=\E[7m:up=\E[A:\ - :sc=\E7:rc=\E8:xn: -qB|bg|bg2.0nv|bgnv:BBN BitGraph Terminal (normal video):\ - :is=\E>\E[?5l\E[?7h:\ - :if=/usr/lib/tabset/vt100:tc=bgn: -qB|bg|bg2.0rv|bgrv:BBN BitGraph Terminal (reverse video):\ - :is=\E>\E[?5h\E[?7h:\ - :if=/usr/lib/tabset/vt100:tc=bgn: -qB|bg|bg1.25|BBN BitGraph terminal:\ - :al=2*\E[L:bs:cd=150\E[J:ce=2\E[K:cl=150\E[H\E[J:cm=%i\E[%d;%dH:\ - :co#85:dl=2*\E[M:\ - :is=\E<:\ - :k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:\ - :kd=\E[B:ke=\E>:kl=\E[D:kr=\E[C:ks=\E=:ku=\E[A:\ - :l1=PF1:l2=PF2:l3=PF3:l4=PF4:\ - :li#64:nd=\E[C:ns:pt:se=\E[0m:so=\E[7m:up=\E[A: -qB|bg|bg1.25nv|:BBN BitGraph Terminal (normal video):\ - :is=\E<\E>\E[?5l\E[?7h:tc=bg1.25: -qB|bg|bg1.25rv|:BBN BitGraph Terminal (reverse video):\ - :is=\E<\E>\E[?5h\E[?7h:tc=bg1.25: -qN|nucterm|rayterm|NUC homebrew:\ - :am:bs:cl=1^L:li#24:co#80:nd=^C:up=^N:ho=^B:ll=^K:ce=^A:cd=^E: -qb|ex3000:\ - :li#24:co#80:ho=^Q: -qc|carlock|klc:\ - :al=^E:am:bs:ce=^U:cl=100^Z:cm=\E=%+ %+ :co#80:dc=\177:dl=^D:dm=:\ - :ed=:ei=^T:ho=^^:im=^T:li#24:nd=^L:se=^V:so=^V:up=^K:vb=\EV\EV: -qe|exidy|exidy2500|exidy sorcerer as dm2500:\ - :al=^P^J^X:am:bs:ce=^W:cl=^^:cm=^L%r%n%.%.:co#64:\ - :dc=\b:dl=^P^Z^X:dm=^P:ed=^X:ei=^X:ho=^B:ic=^\:\ - :im=^P:li#30:nd=^\:pt:so=^N:se=^X:up=^Z: -qn|netx|netronics:\ - :bs:cd=2000^F^E:ce=1600^E:cl=466^L:cm=\E=%+@%+@:co#64:ho=^D:\ - :li#16:ma=j^Jk^Pl :nd=\E+@A:pc=\200:sr=\E=@@^K:up=^K: -# This came from the comp ctr who got it from some user. Smart indeed! -qs|sexidy|exidy smart:\ - :li#24:co#64:cl=^l:ho=^q:nd=^s:up=^w:bs:bc=^a:ma=^x^J:kd=^S: -qu|ubell|ubellchar:if=/usr/staff/michael/term/startup:\ - :am:bs:pt:ce=\Ed:cl=^Z:cm=\E=%+ %+ :co#80:li#24:nd=^L:up=^K:\ - :ma=j^Jk^P^K^Pl :ho=^^: -qw|ttyWilliams:\ - :co#80:li#12:bc=^Y:do=^K:up=^Z:cl=^^:ce=^_:am:ho=^]:nd=^X: -qx|xitex|xitex sct-100:\ - :bs:cd=2000^F^E:ce=1600^E:cl=400^L:cm=\E=%+@%+@:co#64:ho=^D:\ - :li#16:ma=j^Jk^Pl :nd=\E+@A:pc=\200:sr=\E=@@^K:up=^K: -t3|ti|ti700|ti733|735|ti735|ti silent 700:\ - :bs:co#80:hc:os:dC#162: -t4|ti745|745|743|ti silent 745:\ - :bs:co#80:hc:os: -# There are some tvi's that require incredible amounts of padding and -# some that don't. I'm assuming 912 and 920 are the old slow ones, -# and 912b, 912c, 920b, 920c are the new ones that don't need padding. -v1|tvi912|912|920|tvi920|old televideo:if=/usr/lib/tabset/stdcrt:\ - :al=33*\EE:am:bs:ce=\ET:cm=\E=%+ %+ :cl=^Z:co#80:dc=\EW:dl=33*\ER:ei=:\ - :kb=^h:ku=^K:kd=^J:kl=^H:kr=^L:k0=^A@\r:k1=^AA\r:k2=^AB\r:k3=^AC\r:\ - :k4=^AD\r:k5=^AE\r:k6=^AF\r:k7=^AG\r:k8=^AH\r:k9=^AI\r:\ - :ho=^^:im=:ic=\EQ:li#24:nd=^L:pt:se=\Ek:so=\Ej:up=^K:us=\El:ue=\Em:\ - :ma=^K^P^L :sg=1:ug=1: -v2|912b|912c|920b|920c|tvi|new televideo:\ - :al=5*\EE:dl=5*\ER:tc=912: -# Note two things called "teleray". Reorder should move the common one -# to the front if you have either. A dumb teleray with the cursor stuck -# on the bottom and no obvious model number is probably a 3700. -y1|t3700|teleray|dumb teleray 3700:\ - :bs:cl=^L:co#80:li#24: -y3|t3800|teleray 3800 series: \ - :bs:cd=\EJ:ce=\EK:cl=^L:cm=\EY%+ %+ :co#80: \ - :do=\n:ho=\EH:li#24:ll=\EY7 :nd=\EC:pt:up=^K: -y6|t1061|t10|teleray|teleray 1061:if=/usr/lib/tabset/teleray:\ - :al=2*\EL:am:bs:cd=1\EJ:ce=\EK:cl=1^L:cm=\EY%+ %+ :co#80:\ - :dc=\EQ:dl=2*\EM:ei=:ho=\EH:ic=\EP:im=:ip=0.4*:\ - :k1=^Z1:k2=^Z2:k3=^Z3:k4=^Z4:k5=^Z5:k6=^Z6:k7=^Z7:k8=^Z8:\ - :li#24:nd=\EC:pt:se=\ER@:so= \ERD:\ - :is=\Ee\EU01^Z1\EV\EU02^Z2\EV\EU03^Z3\EV\EU04^Z4\EV\EU05^Z5\EV\EU06^Z6\EV\EU07^Z7\EV\EU08^Z8\EV\Ef:\ - :up=\EA:us=\ERH:ue=\ER@:xs:xt:sg=2:ug=1: -yf|t1061f|teleray 1061 with fast PROMs:\ - al=\EL:ip@:dl=\EM:tc=t1061: -rv|vidtx|Radio Shack VIDEOTEX:\ - :cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#32:li#16:nd=\EC:up=\EA: -ae|apple2e|Apple ][e with 80 column card:\ - :am:bs:cd=^K:ce=^]:cl=^L:cm=^^%r%+ %.:co#80:ho=^Y:\ - :ku=^_:kd=^J:kl=^H:kr=^\:kh=^Y:\ - :li#24:nd=^\:up=^_:xn:ma=^\ ^_^P^YH:pt: -# -# ---- -# Convention: First entry is two chars, first char is manufacturer, -# second char is canonical abbreviation for model or mode. -# Second entry is canonical abbreviation. -# Third entry is the one the editor will print with "set" command. -# Last entry is verbose description. -# Others are mnemonic synonyms for the terminal. -# -# If you absolutely MUST check for a specific terminal (this is discouraged) -# check for the 2nd entry (the canonical form) since all other codes are -# subject to change. The two letter codes are there for version 6 and are -# EXTREMELY subject to change, or even to go away if version 6 becomes for -# all practical purposes obsolete. -# -# Special manufacturer codes: -# M: Misc. (with only a few terminals) -# q: Homemade -# s: special (dialup, etc.) -# -# This file is to be installed with an editor script that moves the most -# common terminals to the front of the file. If the source is not available, -# it can be constructed by sorting -# the above entries by the 2 char initial code.
--- a/lib-src/=aixcc.lex Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,301 +0,0 @@ -%Start ErrorText ErrorMessage OtherText - -EC [0-9][0-9][0-9][0-9]-[0-9][0-9][0-9] -D [0-9] -D3 [0-9 ][0-9 ][0-9] -D4 [0-9 ][0-9 ][0-9 ][0-9] -D5 [0-9 ][0-9 ][0-9 ][0-9 ][0-9] -DS [0-9 ] - -%{ -/* moore@wilma.cs.utk.edu - - * Hack to work around the AIX C compiler's brain-damaged error messages - * so that emacs can parse them. It runs /bin/cc as a subprocess, and - * tries to rearrange the error messages so that (a) each message contains - * both the filename and line number where the error occurred, and (b) - * the error message(s) for a particular line get displayed *before* the - * line itself. - * - * to compile: - * lex aixcc.lex - * cc -o aixcc lex.yy.c - * - * - * Copyright December 1991 by Keith Moore - * - * 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., 675 Mass Ave, Cambridge, MA 02139, USA. - * - * - * TODO: figure out how the compiler counts file numbers for included - * files, keep track of which file corresponds to which number, and - * always output the right file name. - */ - -#include <stdio.h> -#include <string.h> - -char *current_file; -int line; -int debug = 0; -char bigbuf[10240]; -char *bufptr = bigbuf; -int last_line_was_error = 0; - -spaces (s) -char *s; -{ - while (*s++) - *bufptr++ = ' '; -} - -char * -strsave (s) -char *s; -{ - char *ptr = malloc (strlen (s) + 1); - strcpy (ptr, s); - return ptr; -} - -yywrap () -{ - *bufptr = '\0'; - bufptr = bigbuf; - while (*bufptr) - putc (*bufptr++, yyout); - return 1; -} - -%} -%% -^File\ Line\ Column\ Message\ text[^\n]* { - /* - * ignore this. don't treat it as error text - */ -} - -^{DS}{DS}{DS}\ {D5}\ \| { - /* - * (optional) nesting level, followed by line number, followed - * by the source code fragment that caused the error - */ - - /* - * save the line number for later - */ - line = atoi (yytext+4); - - if (debug) { - fprintf (yyout, "line <= %d\n", line); - fprintf (yyout, "%s\n", yytext); - } - - /* - * if the last line was an error message, to flush out all of - * the old source text before starting to save the new source text. - */ - if (last_line_was_error) { - *bufptr = '\0'; - bufptr = bigbuf; - while (*bufptr) - putc (*bufptr++, yyout); - bufptr = bigbuf; - last_line_was_error = 0; - } - /* - * stuff enough spaces in the text buffer so that the - * saved text will line up properly when displayed. - */ - spaces (yytext); - - BEGIN ErrorText; /* continue below */ -} - -<ErrorText>[^\n]*$ { - char *ptr; - - /* - * Save the text until we see the error message(s), then print it. - * This because emacs puts the error message at the top of the - * window, and it's nice to be able to see the text below it. - */ - - ptr = yytext; - while (*ptr) - *bufptr++ = *ptr++; - *bufptr++ = '\n'; - - BEGIN 0; -} - -^Processing\ include\ file\ .*$ { - /* - * name of a new include file being processed. Increment file number - * and remember the file name corresponding to this file number. - */ - - current_file = strsave (yytext+24); - - if (debug) { - fprintf (yyout, "current_file <= %s\n", current_file); - fprintf (yyout, "%s\n", yytext); - } -} - -^([a-z]\ -)?\ *{EC}: { - /* - * error message (which we print immediately) preceded by an - * error code (which we ignore) - */ - - fprintf (yyout, "\"%s\", line %d: %c -", current_file, line, *yytext); - last_line_was_error = 1; - BEGIN ErrorMessage; -} - -^{D3}\ {D5}\ {D4}\ {EC}: { - /* - * (optional) nesting level, followed by line number, followed - * by column number, followed by error message text. - */ - - /* - * save the line number for later - */ - line = atoi (yytext+4); - - if (debug) { - fprintf (yyout, "line <= %d\n", line); - fprintf (yyout, "%s\n", yytext); - } - - /* - * if the last line was an error message, flush out all of - * the old source text before printing this error message. - */ - if (last_line_was_error) { - *bufptr = '\0'; - bufptr = bigbuf; - while (*bufptr) - putc (*bufptr++, yyout); - bufptr = bigbuf; - last_line_was_error = 0; - } - fprintf (yyout, "\"%s\", line %d:", current_file, line); - last_line_was_error = 1; - BEGIN ErrorMessage; -} - -<ErrorMessage>[^\n]*$ { - fprintf (yyout, "%s\n", yytext); - BEGIN 0; -} - - -^[^ :]+".c:"\ *$ { - /* name of new source file being processed */ - - char *ptr; - - if (current_file) - free (current_file); - ptr = strchr (yytext, ':'); - *ptr = '\0'; - current_file = strsave (yytext); -} - -^[^\n] { - /* - * other text starting with a newline. We have to break it up this - * way to keep this rule from matching any of the above patterns - */ - - if (last_line_was_error) { - *bufptr = '\0'; - bufptr = bigbuf; - while (*bufptr) - putc (*bufptr++, yyout); - bufptr = bigbuf; - last_line_was_error = 0; - } - - *bufptr++ = *yytext; - BEGIN OtherText; -} - -<OtherText>[^\n]*$ { - char *ptr; - - ptr = yytext; - while (*ptr) - *bufptr++ = *ptr++; - *bufptr++ = '\n'; - - BEGIN 0; -} - -\n ; - -%% - -main (argc, argv) -char **argv; -{ - int pfd[2]; - int child_pid; - int i; - - current_file = strsave ("/dev/null"); - - line = 0; - - for (i = 1; i < argc; ++i) { - char *ptr = strrchr (argv[i], '.'); - if (ptr && ptr[1] == 'c' && ptr[2] == '\0') { - current_file = strsave (argv[i]); - break; - } - } - - if (pipe (pfd) < 0) { - perror ("pipe"); - exit (1); - } - if ((child_pid = fork()) > 0) { - int status; - - close (pfd[1]); - yyin = fdopen (pfd[0], "r"); - yyout = stderr; - yylex(); - - wait (&status); - exit ((status >> 8) & 0xff); - } - else if (child_pid == 0) { - dup2 (pfd[1], 2); - close (pfd[0]); - close (pfd[1]); - argv[0] = "cc"; - execv ("/bin/cc", argv); - perror ("/bin/cc"); - exit (1); - } - else { - perror ("fork"); - exit (1); - } -}
--- a/lib-src/=etags-vmslib.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,155 +0,0 @@ -/* File name wild card expansion for VMS. - This file is part of the etags program. - Copyright (C) 1987 Free Software Foundation, Inc. - - 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, 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., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include <stdio.h> -typedef char tbool; - -/* This is a BUG! ANY arbitrary limit is a BUG! - Won't someone please fix this? */ -#define MAX_FILE_SPEC_LEN 255 -typedef struct { - short curlen; - char body[MAX_FILE_SPEC_LEN + 1]; -} vspec; -#define EOS '\0' -#define NO 0 -#define YES 1 -#define NULL 0 - -/* gfnames - return in successive calls the - name of each file specified by all the remaining args in the command-line - expanding wild cards and - stepping over arguments when they have been processed completely -*/ -char* -gfnames(pac, pav, p_error) - int *pac; - char **pav[]; - tbool *p_error; -{ - static vspec filename = {MAX_FILE_SPEC_LEN, "\0"}; - short fn_exp(); - - while (1) - if (*pac == 0) - { - *p_error = NO; - return(NULL); - } - else switch(fn_exp(&filename, **pav)) - { - case 1: - *p_error = NO; - return(filename.body); - break; - case 0: - --*pac; - ++*pav; - break; - default: - *p_error = YES; - return(filename.body); - break; - } - -} - -/* fn_exp - expand specification of list of file names - returning in each successive call the next filename matching the input - spec. The function expects that each in_spec passed - to it will be processed to completion; in particular, up to and - including the call following that in which the last matching name - is returned, the function ignores the value of in_spec, and will - only start processing a new spec with the following call. - If an error occurs, on return out_spec contains the value - of in_spec when the error occurred. - - With each successive filename returned in out_spec, the - function's return value is one. When there are no more matching - names the function returns zero. If on the first call no file - matches in_spec, or there is any other error, -1 is returned. -*/ - -#include <rmsdef.h> -#include <descrip.h> -#define OUTSIZE MAX_FILE_SPEC_LEN -short -fn_exp(out, in) - vspec *out; - char *in; -{ - static long context = 0; - static struct dsc$descriptor_s o; - static struct dsc$descriptor_s i; - static tbool pass1 = YES; - long status; - short retval; - - if (pass1) - { - pass1 = NO; - o.dsc$a_pointer = (char *) out; - o.dsc$w_length = (short)OUTSIZE; - i.dsc$a_pointer = in; - i.dsc$w_length = (short)strlen(in); - i.dsc$b_dtype = DSC$K_DTYPE_T; - i.dsc$b_class = DSC$K_CLASS_S; - o.dsc$b_dtype = DSC$K_DTYPE_VT; - o.dsc$b_class = DSC$K_CLASS_VS; - } - if ( (status = lib$find_file(&i, &o, &context, 0, 0)) == RMS$_NORMAL) - { - out->body[out->curlen] = EOS; - return(1); - } - else if (status == RMS$_NMF) - retval = 0; - else - { - strcpy(out->body, in); - retval = -1; - } - lib$find_file_end(&context); - pass1 = YES; - return(retval); -} - -#ifndef OLD /* Newer versions of VMS do provide `system'. */ -system(cmd) - char *cmd; -{ - fprintf(stderr, "system() function not implemented under VMS\n"); -} -#endif - -#define VERSION_DELIM ';' -char *massage_name(s) - char *s; -{ - char *start = s; - - for ( ; *s; s++) - if (*s == VERSION_DELIM) - { - *s = EOS; - break; - } - else - *s = tolower(*s); - return(start); -}
--- a/lib-src/=rcs2log Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,673 +0,0 @@ -#! /bin/sh - -# RCS to ChangeLog generator - -# Generate a change log prefix from RCS files (perhaps in the CVS repository) -# and the ChangeLog (if any). -# Output the new prefix to standard output. -# You can edit this prefix by hand, and then prepend it to ChangeLog. - -# Ignore log entries that start with `#'. -# Clump together log entries that start with `{topic} ', -# where `topic' contains neither white space nor `}'. - -Help='The default FILEs are the files registered under the working directory. -Options: - - -c CHANGELOG Output a change log prefix to CHANGELOG (default ChangeLog). - -h HOSTNAME Use HOSTNAME in change log entries (default current host). - -i INDENT Indent change log lines by INDENT spaces (default 8). - -l LENGTH Try to limit log lines to LENGTH characters (default 79). - -R If no FILEs are given and RCS is used, recurse through working directory. - -r OPTION Pass OPTION to subsidiary log command. - -t TABWIDTH Tab stops are every TABWIDTH characters (default 8). - -u "LOGIN<tab>FULLNAME<tab>MAILADDR" Assume LOGIN has FULLNAME and MAILADDR. - -v Append RCS revision to file names in log lines. - --help Output help. - --version Output version number. - -Report bugs to <bug-gnu-emacs@prep.ai.mit.edu>.' - -Id='$Id: rcs2log,v 1.40 1997/05/11 20:02:32 eggert Exp eggert $' - -# Copyright 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -# 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, 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; see the file COPYING. If not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. - -Copyright='Copyright 1997 Free Software Foundation, Inc. -This program comes with NO WARRANTY, to the extent permitted by law. -You may redistribute copies of this program -under the terms of the GNU General Public License. -For more information about these matters, see the files named COPYING. -Author: Paul Eggert <eggert@twinsun.com>' - -tab=' ' -nl=' -' - -# Parse options. - -# defaults -: ${AWK=awk} -: ${TMPDIR=/tmp} -changelog=ChangeLog # change log file name -datearg= # rlog date option -hostname= # name of local host (if empty, will deduce it later) -indent=8 # indent of log line -length=79 # suggested max width of log line -logins= # login names for people we know fullnames and mailaddrs of -loginFullnameMailaddrs= # login<tab>fullname<tab>mailaddr triplets -logTZ= # time zone for log dates (if empty, use local time) -recursive= # t if we want recursive rlog -revision= # t if we want revision numbers -rlog_options= # options to pass to rlog -tabwidth=8 # width of horizontal tab - -while : -do - case $1 in - -c) changelog=${2?}; shift;; - -i) indent=${2?}; shift;; - -h) hostname=${2?}; shift;; - -l) length=${2?}; shift;; - -[nu]) # -n is obsolescent; it is replaced by -u. - case $1 in - -n) case ${2?}${3?}${4?} in - *"$tab"* | *"$nl"*) - echo >&2 "$0: -n '$2' '$3' '$4': tabs, newlines not allowed" - exit 1 - esac - case $loginFullnameMailaddrs in - '') loginFullnameMailaddrs=$2$tab$3$tab$4;; - ?*) loginFullnameMailaddrs=$loginFullnameMailaddrs$nl$2$tab$3$tab$4 - esac - shift; shift; shift;; - -u) - # If $2 is not tab-separated, use colon for separator. - case ${2?} in - *"$nl"*) - echo >&2 "$0: -u '$2': newlines not allowed" - exit 1;; - *"$tab"*) - t=$tab;; - *) - t=: - esac - case $2 in - *"$t"*"$t"*"$t"*) - echo >&2 "$0: -u '$2': too many fields" - exit 1;; - *"$t"*"$t"*) - ;; - *) - echo >&2 "$0: -u '$2': not enough fields" - exit 1 - esac - case $loginFullnameMailaddrs in - '') loginFullnameMailaddrs=$2;; - ?*) loginFullnameMailaddrs=$loginFullnameMailaddrs$nl$2 - esac - shift - esac - case $logins in - '') logins=$login;; - ?*) logins=$logins$nl$login - esac - ;; - -r) - case $rlog_options in - '') rlog_options=${2?};; - ?*) rlog_options=$rlog_options$nl${2?} - esac - shift;; - -R) recursive=t;; - -t) tabwidth=${2?}; shift;; - -v) revision=t;; - --version) - set $Id - rcs2logVersion=$3 - echo >&2 "rcs2log (GNU Emacs) $rcs2logVersion$nl$Copyright" - exit 0;; - -*) echo >&2 "Usage: $0 [OPTION]... [FILE ...]$nl$Help" - case $1 in - --help) exit 0;; - *) exit 1 - esac;; - *) break - esac - shift -done - -month_data=' - m[0]="Jan"; m[1]="Feb"; m[2]="Mar" - m[3]="Apr"; m[4]="May"; m[5]="Jun" - m[6]="Jul"; m[7]="Aug"; m[8]="Sep" - m[9]="Oct"; m[10]="Nov"; m[11]="Dec" -' - - -# Put rlog output into $rlogout. - -# If no rlog options are given, -# log the revisions checked in since the first ChangeLog entry. -# Since ChangeLog is only by date, some of these revisions may be duplicates of -# what's already in ChangeLog; it's the user's responsibility to remove them. -case $rlog_options in -'') - if test -s "$changelog" - then - e=' - /^[0-9]+-[0-9][0-9]-[0-9][0-9]/{ - # ISO 8601 date - print $1 - exit - } - /^... ... [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]:[0-9][0-9] [0-9]+ /{ - # old-fashioned date and time (Emacs 19.31 and earlier) - '"$month_data"' - year = $5 - for (i=0; i<=11; i++) if (m[i] == $2) break - dd = $3 - printf "%d-%02d-%02d\n", year, i+1, dd - exit - } - ' - d=`$AWK "$e" <"$changelog"` || exit - case $d in - ?*) datearg="-d>$d" - esac - fi -esac - -# Use TZ specified by ChangeLog local variable, if any. -if test -s "$changelog" -then - extractTZ=' - /^.*change-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*"\([^"]*\)".*/{ - s//\1/; p; q - } - /^.*change-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*t.*/{ - s//UTC0/; p; q - } - ' - logTZ=`tail "$changelog" | sed -n "$extractTZ"` - case $logTZ in - ?*) TZ=$logTZ; export TZ - esac -fi - -# If CVS is in use, examine its repository, not the normal RCS files. -if test ! -f CVS/Repository -then - rlog=rlog - repository= -else - rlog='cvs -q log' - repository=`sed 1q <CVS/Repository` || exit - test ! -f CVS/Root || CVSROOT=`cat <CVS/Root` || exit - case $CVSROOT in - *:/*) - # remote repository - ;; - *) - # local repository - case $repository in - /*) ;; - *) repository=${CVSROOT?}/$repository - esac - if test ! -d "$repository" - then - echo >&2 "$0: $repository: bad repository (see CVS/Repository)" - exit 1 - fi - esac -fi - -# Use $rlog's -zLT option, if $rlog supports it. -case `$rlog -zLT 2>&1` in -*' option'*) ;; -*) - case $rlog_options in - '') rlog_options=-zLT;; - ?*) rlog_options=-zLT$nl$rlog_options - esac -esac - -# With no arguments, examine all files under the RCS directory. -case $# in -0) - case $repository in - '') - oldIFS=$IFS - IFS=$nl - case $recursive in - t) - RCSdirs=`find . -name RCS -type d -print` - filesFromRCSfiles='s|,v$||; s|/RCS/|/|; s|^\./||' - files=` - { - case $RCSdirs in - ?*) find $RCSdirs \ - -type f \ - ! -name '*_' \ - ! -name ',*,' \ - ! -name '.*_' \ - ! -name .rcsfreeze.log \ - ! -name .rcsfreeze.ver \ - -print - esac - find . -name '*,v' -print - } | - sort -u | - sed "$filesFromRCSfiles" - `;; - *) - files= - for file in RCS/.* RCS/* .*,v *,v - do - case $file in - RCS/. | RCS/.. | RCS/,*, | RCS/*_) continue;; - RCS/.rcsfreeze.log | RCS/.rcsfreeze.ver) continue;; - RCS/.\* | RCS/\* | .\*,v | \*,v) test -f "$file" || continue;; - RCS/*,v | RCS/.*,v) ;; - RCS/* | RCS/.*) test -f "$file" || continue - esac - case $files in - '') files=$file;; - ?*) files=$files$nl$file - esac - done - case $files in - '') exit 0 - esac - esac - set x $files - shift - IFS=$oldIFS - esac -esac - -llogout=$TMPDIR/rcs2log$$l -rlogout=$TMPDIR/rcs2log$$r -trap exit 1 2 13 15 -trap "rm -f $llogout $rlogout; exit 1" 0 - -case $datearg in -?*) $rlog $rlog_options "$datearg" ${1+"$@"} >$rlogout;; -'') $rlog $rlog_options ${1+"$@"} >$rlogout -esac || exit - - -# Get the full name of each author the logs mention, and set initialize_fullname -# to awk code that initializes the `fullname' awk associative array. -# Warning: foreign authors (i.e. not known in the passwd file) are mishandled; -# you have to fix the resulting output by hand. - -initialize_fullname= -initialize_mailaddr= - -case $loginFullnameMailaddrs in -?*) - case $loginFullnameMailaddrs in - *\"* | *\\*) - sed 's/["\\]/\\&/g' >$llogout <<EOF || exit -$loginFullnameMailaddrs -EOF - loginFullnameMailaddrs=`cat $llogout` - esac - - oldIFS=$IFS - IFS=$nl - for loginFullnameMailaddr in $loginFullnameMailaddrs - do - case $loginFullnameMailaddr in - *"$tab"*) IFS=$tab;; - *) IFS=: - esac - set x $loginFullnameMailaddr - login=$2 - fullname=$3 - mailaddr=$4 - initialize_fullname="$initialize_fullname - fullname[\"$login\"] = \"$fullname\"" - initialize_mailaddr="$initialize_mailaddr - mailaddr[\"$login\"] = \"$mailaddr\"" - done - IFS=$oldIFS -esac - -case $llogout in -?*) sort -u -o $llogout <<EOF || exit -$logins -EOF -esac -output_authors='/^date: / { - if ($2 ~ /^[0-9]*[-\/][0-9][0-9][-\/][0-9][0-9]$/ && $3 ~ /^[0-9][0-9]:[0-9][0-9]:[0-9][0-9][-+0-9:]*;$/ && $4 == "author:" && $5 ~ /^[^;]*;$/) { - print substr($5, 1, length($5)-1) - } -}' -authors=` - $AWK "$output_authors" <$rlogout | - case $llogout in - '') sort -u;; - ?*) sort -u | comm -23 - $llogout - esac -` -case $authors in -?*) - cat >$llogout <<EOF || exit -$authors -EOF - initialize_author_script='s/["\\]/\\&/g; s/.*/author[\"&\"] = 1/' - initialize_author=`sed -e "$initialize_author_script" <$llogout` - awkscript=' - BEGIN { - alphabet = "abcdefghijklmnopqrstuvwxyz" - ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - '"$initialize_author"' - } - { - if (author[$1]) { - fullname = $5 - if (fullname ~ /[0-9]+-[^(]*\([0-9]+\)$/) { - # Remove the junk from fullnames like "0000-Admin(0000)". - fullname = substr(fullname, index(fullname, "-") + 1) - fullname = substr(fullname, 1, index(fullname, "(") - 1) - } - if (fullname ~ /,[^ ]/) { - # Some sites put comma-separated junk after the fullname. - # Remove it, but leave "Bill Gates, Jr" alone. - fullname = substr(fullname, 1, index(fullname, ",") - 1) - } - abbr = index(fullname, "&") - if (abbr) { - a = substr($1, 1, 1) - A = a - i = index(alphabet, a) - if (i) A = substr(ALPHABET, i, 1) - fullname = substr(fullname, 1, abbr-1) A substr($1, 2) substr(fullname, abbr+1) - } - - # Quote quotes and backslashes properly in full names. - # Do not use gsub; traditional awk lacks it. - quoted = "" - rest = fullname - for (;;) { - p = index(rest, "\\") - q = index(rest, "\"") - if (p) { - if (q && q<p) p = q - } else { - if (!q) break - p = q - } - quoted = quoted substr(rest, 1, p-1) "\\" substr(rest, p, 1) - rest = substr(rest, p+1) - } - - printf "fullname[\"%s\"] = \"%s%s\"\n", $1, quoted, rest - author[$1] = 0 - } - } - ' - - initialize_fullname=` - ( - cat /etc/passwd - for author in $authors - do NIS_PATH= nismatch $author passwd.org_dir - done - ypmatch $authors passwd - ) 2>/dev/null | - $AWK -F: "$awkscript" - `$initialize_fullname -esac - - -# Function to print a single log line. -# We don't use awk functions, to stay compatible with old awk versions. -# `Log' is the log message (with \n replaced by \001). -# `files' contains the affected files. -printlogline='{ - - # Following the GNU coding standards, rewrite - # * file: (function): comment - # to - # * file (function): comment - if (Log ~ /^\([^)]*\): /) { - i = index(Log, ")") - files = files " " substr(Log, 1, i) - Log = substr(Log, i+3) - } - - # If "label: comment" is too long, break the line after the ":". - sep = " " - if ('"$length"' <= '"$indent"' + 1 + length(files) + index(Log, SOH)) sep = "\n" indent_string - - # Print the label. - printf "%s*%s:", indent_string, files - - # Print each line of the log, transliterating \001 to \n. - while ((i = index(Log, SOH)) != 0) { - logline = substr(Log, 1, i-1) - if (logline ~ /[^'"$tab"' ]/) { - printf "%s%s\n", sep, logline - } else { - print "" - } - sep = indent_string - Log = substr(Log, i+1) - } -}' - -# Pattern to match the `revision' line of rlog output. -rlog_revision_pattern='^revision [0-9]+\.[0-9]+(\.[0-9]+\.[0-9]+)*(['"$tab"' ]+locked by: [^'"$tab"' $,.0-9:;@]*[^'"$tab"' $,:;@][^'"$tab"' $,.0-9:;@]*;)?['"$tab"' ]*$' - -case $hostname in -'') - hostname=`( - hostname || uname -n || uuname -l || cat /etc/whoami - ) 2>/dev/null` || { - echo >&2 "$0: cannot deduce hostname" - exit 1 - } - - case $hostname in - *.*) ;; - *) - domainname=`(domainname) 2>/dev/null` && - case $domainname in - *.*) hostname=$hostname.$domainname - esac - esac -esac - - -# Process the rlog output, generating ChangeLog style entries. - -# First, reformat the rlog output so that each line contains one log entry. -# Transliterate \n to \001 so that multiline entries fit on a single line. -# Discard irrelevant rlog output. -$AWK <$rlogout ' - BEGIN { repository = "'"$repository"'" } - /^RCS file:/ { - if (repository != "") { - filename = $3 - if (substr(filename, 1, length(repository) + 1) == repository "/") { - filename = substr(filename, length(repository) + 2) - } - if (filename ~ /,v$/) { - filename = substr(filename, 1, length(filename) - 2) - } - if (filename ~ /(^|\/)Attic\/[^\/]*$/) { - i = length(filename) - while (substr(filename, i, 1) != "/") i-- - filename = substr(filename, 1, i - 6) substr(filename, i + 1) - } - } - rev = "?" - } - /^Working file:/ { if (repository == "") filename = $3 } - /'"$rlog_revision_pattern"'/, /^(-----------*|===========*)$/ { - if ($0 ~ /'"$rlog_revision_pattern"'/) { - rev = $2 - next - } - if ($0 ~ /^date: [0-9][- +\/0-9:]*;/) { - date = $2 - if (date ~ /\//) { - # This is a traditional RCS format date YYYY/MM/DD. - # Replace "/"s with "-"s to get ISO format. - newdate = "" - while ((i = index(date, "/")) != 0) { - newdate = newdate substr(date, 1, i-1) "-" - date = substr(date, i+1) - } - date = newdate date - } - time = substr($3, 1, length($3) - 1) - author = substr($5, 1, length($5)-1) - printf "%s %s %s %s %s %c", filename, rev, date, time, author, 1 - rev = "?" - next - } - if ($0 ~ /^branches: /) { next } - if ($0 ~ /^(-----------*|===========*)$/) { print ""; next } - if ($0 == "Initial revision" || $0 ~ /^file .+ was initially added on branch .+\.$/) { - $0 = "New file." - } - printf "%s%c", $0, 1 - } -' | - -# Now each line is of the form -# FILENAME REVISION YYYY-MM-DD HH:MM:SS[+-TIMEZONE] AUTHOR \001LOG -# where \001 stands for a carriage return, -# and each line of the log is terminated by \001 instead of \n. -# Sort the log entries, first by date+time (in reverse order), -# then by author, then by log entry, and finally by file name and revision -# (just in case). -sort +2 -4r +4 +0 | - -# Finally, reformat the sorted log entries. -$AWK ' - BEGIN { - logTZ = "'"$logTZ"'" - revision = "'"$revision"'" - - # Some awk variants do not understand "\001", so we have to - # put the char directly in the file. - SOH="" # <-- There is a single SOH (octal code 001) here. - - # Initialize the fullname and mailaddr associative arrays. - '"$initialize_fullname"' - '"$initialize_mailaddr"' - - # Initialize indent string. - indent_string = "" - i = '"$indent"' - if (0 < '"$tabwidth"') - for (; '"$tabwidth"' <= i; i -= '"$tabwidth"') - indent_string = indent_string "\t" - while (1 <= i--) - indent_string = indent_string " " - } - - { - newlog = substr($0, 1 + index($0, SOH)) - - # Ignore log entries prefixed by "#". - if (newlog ~ /^#/) { next } - - if (Log != newlog || date != $3 || author != $5) { - - # The previous log and this log differ. - - # Print the old log. - if (date != "") '"$printlogline"' - - # Logs that begin with "{clumpname} " should be grouped together, - # and the clumpname should be removed. - # Extract the new clumpname from the log header, - # and use it to decide whether to output a blank line. - newclumpname = "" - sep = "\n" - if (date == "") sep = "" - if (newlog ~ /^\{[^'"$tab"' }]*}['"$tab"' ]/) { - i = index(newlog, "}") - newclumpname = substr(newlog, 1, i) - while (substr(newlog, i+1) ~ /^['"$tab"' ]/) i++ - newlog = substr(newlog, i+1) - if (clumpname == newclumpname) sep = "" - } - printf sep - clumpname = newclumpname - - # Get ready for the next log. - Log = newlog - if (files != "") - for (i in filesknown) - filesknown[i] = 0 - files = "" - } - if (date != $3 || author != $5) { - # The previous date+author and this date+author differ. - # Print the new one. - date = $3 - time = $4 - author = $5 - - zone = "" - if (logTZ && ((i = index(time, "-")) || (i = index(time, "+")))) - zone = " " substr(time, i) - - # Print "date[ timezone] fullname <email address>". - # Get fullname and email address from associative arrays; - # default to author and author@hostname if not in arrays. - if (fullname[author]) - auth = fullname[author] - else - auth = author - printf "%s%s %s ", date, zone, auth - if (mailaddr[author]) - printf "<%s>\n\n", mailaddr[author] - else - printf "<%s@%s>\n\n", author, "'"$hostname"'" - } - if (! filesknown[$1]) { - filesknown[$1] = 1 - if (files == "") files = " " $1 - else files = files ", " $1 - if (revision && $2 != "?") files = files " " $2 - } - } - END { - # Print the last log. - if (date != "") { - '"$printlogline"' - printf "\n" - } - } -' && - - -# Exit successfully. - -exec rm -f $llogout $rlogout - -# Local Variables: -# tab-width:4 -# End:
--- a/lib-src/=timer.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,368 +0,0 @@ -/* timer.c --- daemon to provide a tagged interval timer service - - This little daemon runs forever waiting for commands to schedule events. - SIGALRM causes - it to check its queue for events attached to the current second; if - one is found, its label is written to stdout. SIGTERM causes it to - terminate, printing a list of pending events. - - This program is intended to be used with the lisp package called - timer.el. The first such program was written anonymously in 1990. - This version was documented and rewritten for portability by - esr@snark.thyrsus.com, Aug 7 1992. */ - -#include <stdio.h> -#include <signal.h> -#include <errno.h> -#include <sys/types.h> /* time_t */ - -#include <../src/config.h> -#undef read - -#ifdef LINUX -/* Perhaps this is correct unconditionally. */ -#undef signal -#endif -#ifdef _CX_UX -/* I agree with the comment above, this probably should be unconditional (it - * is already unconditional in a couple of other files in this directory), - * but in the spirit of minimizing the effects of my port, I am making it - * conditional on _CX_UX. - */ -#undef signal -#endif - - -extern int errno; -extern char *strerror (); -extern time_t time (); - -/* - * The field separator for input. This character shouldn't occur in dates, - * and should be printable so event strings are readable by people. - */ -#define FS '@' - -struct event - { - char *token; - time_t reply_at; - }; -int events_size; /* How many slots have we allocated? */ -int num_events; /* How many are actually scheduled? */ -struct event *events; /* events[0 .. num_events-1] are the - valid events. */ - -char *pname; /* program name for error messages */ - -/* This buffer is used for reading commands. - We make it longer when necessary, but we never free it. */ -char *buf; -/* This is the allocated size of buf. */ -int buf_size; - -/* Non-zero means don't handle an alarm now; - instead, just set alarm_deferred if an alarm happens. - We set this around parts of the program that call malloc and free. */ -int defer_alarms; - -/* Non-zero if an alarm came in during the reading of a command. */ -int alarm_deferred; - -/* Schedule one event, and arrange an alarm for it. - STR is a string of two fields separated by FS. - First field is string for get_date, saying when to wake-up. - Second field is a token to identify the request. */ - -void -schedule (str) - char *str; -{ - extern time_t get_date (); - extern char *strcpy (); - time_t now; - register char *p; - static struct event *ep; - - /* check entry format */ - for (p = str; *p && *p != FS; p++) - continue; - if (!*p) - { - fprintf (stderr, "%s: bad input format: %s\n", pname, str); - return; - } - *p++ = 0; - - /* allocate an event slot */ - ep = events + num_events; - - /* If the event array is full, stretch it. After stretching, we know - that ep will be pointing to an available event spot. */ - if (ep == events + events_size) - { - int old_size = events_size; - - events_size *= 2; - events = ((struct event *) - realloc (events, events_size * sizeof (struct event))); - if (! events) - { - fprintf (stderr, "%s: virtual memory exhausted.\n", pname); - /* Since there is so much virtual memory, and running out - almost surely means something is very very wrong, - it is best to exit rather than continue. */ - exit (1); - } - - while (old_size < events_size) - events[old_size++].token = NULL; - } - - /* Don't allow users to schedule events in past time. */ - ep->reply_at = get_date (str, NULL); - if (ep->reply_at - time (&now) < 0) - { - fprintf (stderr, "%s: bad time spec: %s%c%s\n", pname, str, FS, p); - return; - } - - /* save the event description */ - ep->token = (char *) malloc ((unsigned) strlen (p) + 1); - if (! ep->token) - { - fprintf (stderr, "%s: malloc %s: %s%c%s\n", - pname, strerror (errno), str, FS, p); - return; - } - - strcpy (ep->token, p); - num_events++; -} - -/* Print the notification for the alarmed event just arrived if any, - and schedule an alarm for the next event if any. */ - -void -notify () -{ - time_t now, tdiff, waitfor = -1; - register struct event *ep; - - /* Inhibit interference with alarms while changing global vars. */ - defer_alarms = 1; - alarm_deferred = 0; - - now = time ((time_t *) NULL); - - for (ep = events; ep < events + num_events; ep++) - /* Are any events ready to fire? */ - if (ep->reply_at <= now) - { - fputs (ep->token, stdout); - putc ('\n', stdout); - fflush (stdout); - free (ep->token); - - /* We now have a hole in the event array; fill it with the last - event. */ - ep->token = events[num_events - 1].token; - ep->reply_at = events[num_events - 1].reply_at; - num_events--; - - /* We ought to scan this event again. */ - ep--; - } - else - { - /* next timeout should be the soonest of any remaining */ - if ((tdiff = ep->reply_at - now) < waitfor || waitfor < 0) - waitfor = (long)tdiff; - } - - /* If there are no more events, we needn't bother setting an alarm. */ - if (num_events > 0) - alarm (waitfor); - - /* Now check if there was another alarm - while we were handling an explicit request. */ - defer_alarms = 0; - if (alarm_deferred) - notify (); - alarm_deferred = 0; -} - -/* Read one command from command from standard input - and schedule the event for it. */ - -void -getevent () -{ - int i; - - /* In principle the itimer should be disabled on entry to this - function, but it really doesn't make any important difference - if it isn't. */ - - if (buf == 0) - { - buf_size = 80; - buf = (char *) malloc (buf_size); - } - - /* Read a line from standard input, expanding buf if it is too short - to hold the line. */ - for (i = 0; ; i++) - { - char c; - int nread; - - if (i >= buf_size) - { - buf_size *= 2; - alarm_deferred = 0; - defer_alarms = 1; - buf = (char *) realloc (buf, buf_size); - defer_alarms = 0; - if (alarm_deferred) - notify (); - alarm_deferred = 0; - } - - /* Read one character into c. */ - while (1) - { - nread = read (fileno (stdin), &c, 1); - - /* Retry after transient error. */ - if (nread < 0 - && (1 -#ifdef EINTR - || errno == EINTR -#endif -#ifdef EAGAIN - || errno == EAGAIN -#endif - )) - continue; - - /* Report serious errors. */ - if (nread < 0) - { - perror ("read"); - exit (1); - } - - /* On eof, exit. */ - if (nread == 0) - exit (0); - - break; - } - - if (c == '\n') - { - buf[i] = '\0'; - break; - } - - buf[i] = c; - } - - /* Register the event. */ - alarm_deferred = 0; - defer_alarms = 1; - schedule (buf); - defer_alarms = 0; - notify (); - alarm_deferred = 0; -} - -/* Handle incoming signal SIG. */ - -SIGTYPE -sigcatch (sig) - int sig; -{ - struct event *ep; - - /* required on older UNIXes; harmless on newer ones */ - signal (sig, sigcatch); - - switch (sig) - { - case SIGALRM: - if (defer_alarms) - alarm_deferred = 1; - else - notify (); - break; - case SIGTERM: - fprintf (stderr, "Events still queued:\n"); - for (ep = events; ep < events + num_events; ep++) - fprintf (stderr, "%d = %ld @ %s\n", - ep - events, ep->reply_at, ep->token); - exit (0); - break; - } -} - -/*ARGSUSED*/ -int -main (argc, argv) - int argc; - char **argv; -{ - for (pname = argv[0] + strlen (argv[0]); - *pname != '/' && pname != argv[0]; - pname--); - if (*pname == '/') - pname++; - - events_size = 16; - events = ((struct event *) malloc (events_size * sizeof (*events))); - num_events = 0; - - signal (SIGALRM, sigcatch); - signal (SIGTERM, sigcatch); - - /* Loop reading commands from standard input - and scheduling alarms accordingly. - The alarms are handled asynchronously, while we wait for commands. */ - while (1) - getevent (); -} - -#ifndef HAVE_STRERROR -char * -strerror (errnum) - int errnum; -{ - extern char *sys_errlist[]; - extern int sys_nerr; - - if (errnum >= 0 && errnum < sys_nerr) - return sys_errlist[errnum]; - return (char *) "Unknown error"; -} - -#endif /* ! HAVE_STRERROR */ - -long * -xmalloc (size) - int size; -{ - register long *val; - - val = (long *) malloc (size); - - if (!val && size) - { - fprintf (stderr, "timer: virtual memory exceeded\n"); - exit (1); - } - - return val; -} - -/* timer.c ends here */
--- a/lib-src/=wakeup.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -/* Program to produce output at regular intervals. */ - -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#include <stdio.h> -#include <sys/types.h> - -#ifdef TIME_WITH_SYS_TIME -#include <sys/time.h> -#include <time.h> -#else -#ifdef HAVE_SYS_TIME_H -#include <sys/time.h> -#else -#include <time.h> -#endif -#endif - -struct tm *localtime (); - -void -main (argc, argv) - int argc; - char **argv; -{ - int period = 60; - time_t when; - struct tm *tp; - - if (argc > 1) - period = atoi (argv[1]); - - while (1) - { - /* Make sure wakeup stops when Emacs goes away. */ - if (getppid () == 1) - exit (0); - printf ("Wake up!\n"); - fflush (stdout); - /* If using a period of 60, produce the output when the minute - changes. */ - if (period == 60) - { - time (&when); - tp = localtime (&when); - sleep (60 - tp->tm_sec); - } - else - sleep (period); - } -}
--- a/lib-src/env.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,353 +0,0 @@ -/* env - manipulate environment and execute a program in that environment - Copyright (C) 1986, 1994 Free Software Foundation, Inc. - - 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, 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., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -/* Mly 861126 */ - -/* If first argument is "-", then a new environment is constructed - from scratch; otherwise the environment is inherited from the parent - process, except as modified by other options. - - So, "env - foo" will invoke the "foo" program in a null environment, - whereas "env foo" would invoke "foo" in the same environment as that - passed to "env" itself. - - Subsequent arguments are interpreted as follows: - - * "variable=value" (i.e., an arg containing a "=" character) - means to set the specified environment variable to that value. - `value' may be of zero length ("variable="). Note that setting - a variable to a zero-length value is different from unsetting it. - - * "-u variable" or "-unset variable" - means to unset that variable. - If that variable isn't set, does nothing. - - * "-s variable value" or "-set variable value" - same as "variable=value". - - * "-" or "--" - are used to indicate that the following argument is the program - to invoke. This is only necessary when the program's name - begins with "-" or contains a "=". - - * anything else - The first remaining argument specifies a program to invoke - (it is searched for according to the specification of the PATH - environment variable) and any arguments following that are - passed as arguments to that program. - - If no program-name is specified following the environment - specifications, the resulting environment is printed. - This is like specifying a program-name of "printenv". - - Examples: - If the environment passed to "env" is - { USER=rms EDITOR=emacs PATH=.:/gnubin:/hacks } - - * "env DISPLAY=gnu:0 nemacs" - calls "nemacs" in the environment - { USER=rms EDITOR=emacs PATH=.:/gnubin:/hacks DISPLAY=gnu:0 } - - * "env - USER=foo /hacks/hack bar baz" - calls the "hack" program on arguments "bar" and "baz" - in an environment in which the only variable is "USER". - Note that the "-" option clears out the PATH variable, - so one should be careful to specify in which directory - to find the program to call. - - * "env -u EDITOR USER=foo PATH=/energy -- e=mc2 bar baz" - The program "/energy/e=mc2" is called with environment - { USER=foo PATH=/energy } -*/ - -#ifdef EMACS -#define NO_SHORTNAMES -#include "../src/config.h" -#endif /* EMACS */ - -#include <stdio.h> - -extern int execvp (); - -char *xmalloc (), *xrealloc (); -char *concat (); - -extern char **environ; - -char **nenv; -int nenv_size; - -char *progname; -void setenv (); -void fatal (); -char *myindex (); - -extern char *strerror (); - - -main (argc, argv, envp) - register int argc; - register char **argv; - char **envp; -{ - register char *tem; - - progname = argv[0]; - argc--; - argv++; - - nenv_size = 100; - nenv = (char **) xmalloc (nenv_size * sizeof (char *)); - *nenv = (char *) 0; - - /* "-" flag means to not inherit parent's environment */ - if (argc && !strcmp (*argv, "-")) - { - argc--; - argv++; - } - else - /* Else pass on existing env vars. */ - for (; *envp; envp++) - { - tem = myindex (*envp, '='); - if (tem) - { - *tem = '\000'; - setenv (*envp, tem + 1); - } - } - - while (argc > 0) - { - tem = myindex (*argv, '='); - if (tem) - /* If arg contains a "=" it specifies to set a variable */ - { - *tem = '\000'; - setenv (*argv, tem + 1); - argc--; - argv++; - continue; - } - - if (**argv != '-') - /* Remaining args are program name and args to pass it */ - break; - - if (argc < 2) - fatal ("no argument for `%s' option", *argv); - if (!strcmp (*argv, "-u") - || !strcmp (*argv, "-unset")) - /* Unset a variable */ - { - argc--; - argv++; - setenv (*argv, (char *) 0); - argc--; - argv++; - } - else if (!strcmp (*argv, "-s") || - !strcmp (*argv, "-set")) - /* Set a variable */ - { - argc--; - argv++; - tem = *argv; - if (argc < 2) - fatal ("no value specified for variable \"%s\"", tem); - argc--; - argv++; - setenv (tem, *argv); - argc--; - argv++; - } - else if (!strcmp (*argv, "-") || !strcmp (*argv, "--")) - { - argc--; - argv++; - break; - } - else - { - fatal ("unrecognized option `%s'", *argv); - } - } - - /* If no program specified print the environment and exit */ - if (argc <= 0) - { - while (*nenv) - printf ("%s\n", *nenv++); - exit (0); - } - else - { - extern int errno; - extern char *strerror (); - - environ = nenv; - (void) execvp (*argv, argv); - - fprintf (stderr, "%s: cannot execute `%s': %s\n", - progname, *argv, strerror (errno)); - exit (errno != 0 ? errno : 1); - } -} - -void -setenv (var, val) - register char *var, *val; -{ - register char **e; - int len = strlen (var); - - { - register char *tem = myindex (var, '='); - if (tem) - fatal ("environment variable names can not contain `=': %s", var); - else if (*var == '\000') - fatal ("zero-length environment variable name specified"); - } - - for (e = nenv; *e; e++) - if (!strncmp (var, *e, len) && (*e)[len] == '=') - { - if (val) - goto set; - else - do - { - *e = *(e + 1); - } while (*e++); - return; - } - - if (!val) - return; /* Nothing to unset */ - - len = e - nenv; - if (len + 1 >= nenv_size) - { - nenv_size += 100; - nenv = (char **) xrealloc (nenv, nenv_size * sizeof (char *)); - e = nenv + len; - } - -set: - val = concat (var, "=", val); - if (*e) - free (*e); - else - *(e + 1) = (char *) 0; - *e = val; - return; -} - -void -fatal (msg, arg1, arg2) - char *msg, *arg1, *arg2; -{ - fprintf (stderr, "%s: ", progname); - fprintf (stderr, msg, arg1, arg2); - putc ('\n', stderr); - exit (1); -} - - -extern char *malloc (), *realloc (); - -void -memory_fatal () -{ - fatal ("virtual memory exhausted"); -} - -char * -xmalloc (size) - int size; -{ - register char *value; - value = (char *) malloc (size); - if (!value) - memory_fatal (); - return (value); -} - -char * -xrealloc (ptr, size) - char *ptr; - int size; -{ - register char *value; - value = (char *) realloc (ptr, size); - if (!value) - memory_fatal (); - return (value); -} - -/* Return a newly-allocated string whose contents concatenate - those of S1, S2, S3. */ - -char * -concat (s1, s2, s3) - char *s1, *s2, *s3; -{ - int len1 = strlen (s1), len2 = strlen (s2), len3 = strlen (s3); - char *result = (char *) xmalloc (len1 + len2 + len3 + 1); - - strcpy (result, s1); - strcpy (result + len1, s2); - strcpy (result + len1 + len2, s3); - result[len1 + len2 + len3] = 0; - - return result; -} - -/* Return a pointer to the first occurrence in STR of C, - or 0 if C does not occur. */ - -char * -myindex (str, c) - char *str; - char c; -{ - char *s = str; - - while (*s) - { - if (*s == c) - return s; - s++; - } - return 0; -} - -#ifndef HAVE_STRERROR -char * -strerror (errnum) - int errnum; -{ - extern char *sys_errlist[]; - extern int sys_nerr; - - if (errnum >= 0 && errnum < sys_nerr) - return sys_errlist[errnum]; - return (char *) "Unknown error"; -} - -#endif /* ! HAVE_STRERROR */
--- a/lib-src/make-path.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,105 +0,0 @@ -/* Make all the directories along a path. - Copyright (C) 1992 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, 675 Mass Ave, Cambridge, MA 02139, USA. */ - -/* This program works like mkdir, except that it generates - intermediate directories if they don't exist. This is just like - the `mkdir -p' command on most systems; unfortunately, the mkdir - command on some of the purer BSD systems (like Mt. Xinu) don't have - that option. */ - -#include <sys/types.h> -#include <sys/stat.h> -#include <stdio.h> -#include <errno.h> - -extern int errno; - -char *prog_name; - -/* Create directory DIRNAME if it does not exist already. - Then give permission for everyone to read and search it. - Return 0 if successful, 1 if not. */ - -int -touchy_mkdir (dirname) - char *dirname; -{ - struct stat buf; - - /* If DIRNAME already exists and is a directory, don't create. */ - if (! (stat (dirname, &buf) >= 0 - && (buf.st_mode & S_IFMT) == S_IFDIR)) - { - /* Otherwise, try to make it. If DIRNAME exists but isn't a directory, - this will signal an error. */ - if (mkdir (dirname, 0777) < 0) - { - fprintf (stderr, "%s: ", prog_name); - perror (dirname); - return 1; - } - } - - /* Make sure everyone can look at this directory. */ - if (stat (dirname, &buf) < 0) - { - fprintf (stderr, "%s: ", prog_name); - perror (dirname); - return 1; - } - if (chmod (dirname, 0555 | (buf.st_mode & 0777)) < 0) - { - fprintf (stderr, "%s: ", prog_name); - perror (dirname); - } - - return 0; -} - -int -main (argc, argv) - int argc; - char **argv; -{ - prog_name = *argv; - - for (argc--, argv++; argc > 0; argc--, argv++) - { - char *dirname = *argv; - int i; - - /* Stop at each slash in dirname and try to create the directory. - Skip any initial slash. */ - for (i = (dirname[0] == '/') ? 1 : 0; dirname[i]; i++) - if (dirname[i] == '/') - { - dirname[i] = '\0'; - if (touchy_mkdir (dirname) < 0) - goto next_dirname; - dirname[i] = '/'; - } - - touchy_mkdir (dirname); - - next_dirname: - ; - } - - return 0; -}
--- a/lisp/=ada.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,734 +0,0 @@ -;;; ada.el --- Ada editing support package in GNUlisp. v1.0 - -;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -;; Author: Vincent Broman <broman@bugs.nosc.mil> -;; Keywords: languages - -;; 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: - -;; Created May 1987. -;; (borrows heavily from Mick Jordan's Modula-2 package for GNU, -;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.) - -;;; Code: - -(defvar ada-mode-syntax-table nil - "Syntax table in use in Ada-mode buffers.") - -(let ((table (make-syntax-table))) - (modify-syntax-entry ?_ "_" table) - (modify-syntax-entry ?\# "_" table) - (modify-syntax-entry ?\( "()" table) - (modify-syntax-entry ?\) ")(" table) - (modify-syntax-entry ?$ "." table) - (modify-syntax-entry ?* "." table) - (modify-syntax-entry ?/ "." table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?- ". 12" table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?\& "." table) - (modify-syntax-entry ?\| "." table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (modify-syntax-entry ?\[ "." table) - (modify-syntax-entry ?\] "." table) - (modify-syntax-entry ?\{ "." table) - (modify-syntax-entry ?\} "." table) - (modify-syntax-entry ?. "." table) - (modify-syntax-entry ?\\ "." table) - (modify-syntax-entry ?: "." table) - (modify-syntax-entry ?\; "." table) - (modify-syntax-entry ?\' "." table) - (modify-syntax-entry ?\" "\"" table) - (modify-syntax-entry ?\n ">" table) - (setq ada-mode-syntax-table table)) - -;; Strings are a real pain in Ada because both ' and " can appear in a -;; non-string quote context (the former as an operator, the latter as a -;; character string). We follow the least losing solution, in which only " is -;; a string quote. Therefore a character string of the form '"' will throw -;; fontification off on the wrong track. - -(defconst ada-font-lock-keywords-1 - (list - ;; - ;; Function, package (body), pragma, procedure, task (body) plus name. - (list (concat "\\<\\(" - "function\\|" - "p\\(ackage\\(\\|[ \t]+body\\)\\|r\\(agma\\|ocedure\\)\\)\\|" - "task\\(\\|[ \t]+body\\)" - "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face) '(6 font-lock-function-name-face nil t))) - "For consideration as a value of `ada-font-lock-keywords'. -This does fairly subdued highlighting.") - -(defconst ada-font-lock-keywords-2 - (append ada-font-lock-keywords-1 - (list - ;; - ;; Main keywords, except those treated specially below. - (concat "\\<\\(" -; ("abort" "abs" "abstract" "accept" "access" "aliased" "all" -; "and" "array" "at" "begin" "case" "declare" "delay" "delta" -; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for" -; "generic" "if" "in" "is" "limited" "loop" "mod" "not" -; "null" "or" "others" "private" "protected" -; "range" "record" "rem" "renames" "requeue" "return" "reverse" -; "select" "separate" "tagged" "task" "terminate" "then" "until" -; "while" "xor") - "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|" - "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|" - "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|" - "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|" - "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|" - "o\\(r\\|thers\\)\\|pr\\(ivate\\|otected\\)\\|" - "r\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|" - "se\\(lect\\|parate\\)\\|" - "t\\(a\\(gged\\|sk\\)\\|erminate\\|hen\\)\\|until\\|while\\|xor" - "\\)\\>") - ;; - ;; Anything following end and not already fontified is a body name. - '("\\<\\(end\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) -; ;; -; ;; Variable name plus optional keywords followed by a type name. Slow. -; (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:" -; "[ \t]*\\(constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*" -; "\\(\\sw+\\(\\.\\sw*\\)*\\)?") -; '(1 font-lock-variable-name-face) -; '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t)) - ;; - ;; Optional keywords followed by a type name. - (list (concat ":[ \t]*\\<\\(constant\\|in\\|in[ \t]+out\\|out\\)\\>?[ \t]*" - "\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) - ;; - ;; Keywords followed by a type or function name. - (list (concat "\\<\\(" - "new\\|of\\|subtype\\|type" - "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?") - '(1 font-lock-keyword-face) - '(2 (if (match-beginning 4) - font-lock-function-name-face - font-lock-type-face) nil t)) - ;; - ;; Keywords followed by a reference. - (list (concat "\\<\\(goto\\|raise\\|use\\|when\\|with\\)\\>" - "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t)) - ;; - ;; Goto tags. - '("<<\\(\\sw+\\(\\.\\sw*\\)*\\)>>" 1 font-lock-reference-face) - )) - "For consideration as a value of `ada-font-lock-keywords'. -This does a lot more highlighting.") - -(defvar ada-font-lock-keywords (if font-lock-maximum-decoration - ada-font-lock-keywords-2 - ada-font-lock-keywords-1) - "Additional expressions to highlight in Ada mode.") - -(defvar ada-mode-map nil - "Keymap used in Ada mode.") - -(let ((map (make-sparse-keymap))) - (define-key map "\C-m" 'ada-newline) - (define-key map "\C-?" 'backward-delete-char-untabify) - (define-key map "\C-i" 'ada-tab) - (define-key map "\C-c\C-i" 'ada-untab) - (define-key map "\C-c<" 'ada-backward-to-same-indent) - (define-key map "\C-c>" 'ada-forward-to-same-indent) - (define-key map "\C-ch" 'ada-header) - (define-key map "\C-c(" 'ada-paired-parens) - (define-key map "\C-c-" 'ada-inline-comment) - (define-key map "\C-c\C-a" 'ada-array) - (define-key map "\C-cb" 'ada-exception-block) - (define-key map "\C-cd" 'ada-declare-block) - (define-key map "\C-c\C-e" 'ada-exception) - (define-key map "\C-cc" 'ada-case) - (define-key map "\C-c\C-k" 'ada-package-spec) - (define-key map "\C-ck" 'ada-package-body) - (define-key map "\C-c\C-p" 'ada-procedure-spec) - (define-key map "\C-cp" 'ada-subprogram-body) - (define-key map "\C-c\C-f" 'ada-function-spec) - (define-key map "\C-cf" 'ada-for-loop) - (define-key map "\C-cl" 'ada-loop) - (define-key map "\C-ci" 'ada-if) - (define-key map "\C-cI" 'ada-elsif) - (define-key map "\C-ce" 'ada-else) - (define-key map "\C-c\C-v" 'ada-private) - (define-key map "\C-c\C-r" 'ada-record) - (define-key map "\C-c\C-s" 'ada-subtype) - (define-key map "\C-cs" 'ada-separate) - (define-key map "\C-c\C-t" 'ada-type) - (define-key map "\C-ct" 'ada-tabsize) -;; (define-key map "\C-c\C-u" 'ada-use) -;; (define-key map "\C-c\C-w" 'ada-with) - (define-key map "\C-cw" 'ada-while-loop) - (define-key map "\C-c\C-w" 'ada-when) - (define-key map "\C-cx" 'ada-exit) - (define-key map "\C-cC" 'ada-compile) - (define-key map "\C-cB" 'ada-bind) - (define-key map "\C-cE" 'ada-find-listing) - (define-key map "\C-cL" 'ada-library-name) - (define-key map "\C-cO" 'ada-options-for-bind) - (setq ada-mode-map map)) - -(defvar ada-indent 4 "*Value is the number of columns to indent in Ada-Mode.") - -(defvar ada-comment-end-column) - -(defun ada-mode () -"This is a mode intended to support program development in Ada. -Most control constructs and declarations of Ada can be inserted in the buffer -by typing Control-C followed by a character mnemonic for the construct. - -\\<ada-mode-map>\\[ada-array] array \\[ada-exception-block] exception block -\\[ada-exception] exception \\[ada-declare-block] declare block -\\[ada-package-spec] package spec \\[ada-package-body] package body -\\[ada-procedure-spec] procedure spec \\[ada-subprogram-body] proc/func body -\\[ada-function-spec] func spec \\[ada-for-loop] for loop - \\[ada-if] if - \\[ada-elsif] elsif - \\[ada-else] else -\\[ada-private] private \\[ada-loop] loop -\\[ada-record] record \\[ada-case] case -\\[ada-subtype] subtype \\[ada-separate] separate -\\[ada-type] type \\[ada-tabsize] tab spacing for indents -\\[ada-when] when \\[ada-while] while - \\[ada-exit] exit -\\[ada-paired-parens] paired parens \\[ada-inline-comment] inline comment - \\[ada-header] header spec -\\[ada-compile] compile \\[ada-bind] bind -\\[ada-find-listing] find error list -\\[ada-library-name] name library \\[ada-options-for-bind] options for bind - -\\[ada-backward-to-same-indent] and \\[ada-forward-to-same-indent] move backward and forward respectively to the next line -having the same (or lesser) level of indentation. - -Variable `ada-indent' controls the number of spaces for indent/undent." - (interactive) - (kill-all-local-variables) - (use-local-map ada-mode-map) - (setq major-mode 'ada-mode) - (setq mode-name "Ada") - (make-local-variable 'comment-column) - (setq comment-column 41) - (make-local-variable 'ada-comment-end-column) - (setq ada-comment-end-column 72) - (set-syntax-table ada-mode-syntax-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 'indent-line-function) -; (setq indent-line-function 'c-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "--") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 41) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "--+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'c-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(ada-font-lock-keywords nil t ((?\_ . "w")))) - (run-hooks 'ada-mode-hook)) - -(defun ada-tabsize (s) - "Changes spacing used for indentation. -The prefix argument is used as the new spacing." - (interactive "p") - (setq ada-indent s)) - -(defun ada-newline () - "Start new line and indent to current tab stop." - (interactive) - (let ((ada-cc (current-indentation))) - (newline) - (indent-to ada-cc))) - -(defun ada-tab () - "Indent to next tab stop." - (interactive) - (indent-to (* (1+ (/ (current-indentation) ada-indent)) ada-indent))) - -(defun ada-untab () - "Delete backwards to previous tab stop." - (interactive) - (backward-delete-char-untabify ada-indent nil)) - -(defun ada-go-to-this-indent (step indent-level) - "Move point repeatedly by STEP lines until the current line has -given INDENT-LEVEL or less, or the start or end of the buffer is reached. -Ignore blank lines, statement labels and block or loop names." - (while (and - (zerop (forward-line step)) - (or (looking-at "^[ ]*$") - (looking-at "^[ ]*--") - (looking-at "^<<[A-Za-z0-9_]+>>") - (looking-at "^[A-Za-z0-9_]+:") - (> (current-indentation) indent-level))) - nil)) - -(defun ada-backward-to-same-indent () - "Move point backwards to nearest line with same indentation or less. -If not found, point is left at the top of the buffer." - (interactive) - (ada-go-to-this-indent -1 (current-indentation)) - (back-to-indentation)) - -(defun ada-forward-to-same-indent () - "Move point forwards to nearest line with same indentation or less. -If not found, point is left at the start of the last line in the buffer." - (interactive) - (ada-go-to-this-indent 1 (current-indentation)) - (back-to-indentation)) - -(defun ada-array () - "Insert array type definition. Uses the minibuffer to prompt -for component type and index subtypes." - (interactive) - (insert "array ()") - (backward-char) - (insert (read-string "index subtype[s]: ")) - (end-of-line) - (insert " of ;") - (backward-char) - (insert (read-string "component-type: ")) - (end-of-line)) - -(defun ada-case () - "Build skeleton case statement. -Uses the minibuffer to prompt for the selector expression. -Also builds the first when clause." - (interactive) - (insert "case ") - (insert (read-string "selector expression: ") " is") - (ada-newline) - (ada-newline) - (insert "end case;") - (end-of-line 0) - (ada-tab) - (ada-tab) - (ada-when)) - -(defun ada-declare-block () - "Insert a block with a declare part. -Indent for the first declaration." - (interactive) - (let ((ada-block-name (read-string "[block name]: "))) - (insert "declare") - (cond - ( (not (string-equal ada-block-name "")) - (beginning-of-line) - (open-line 1) - (insert ada-block-name ":") - (next-line 1) - (end-of-line))) - (ada-newline) - (ada-newline) - (insert "begin") - (ada-newline) - (ada-newline) - (if (string-equal ada-block-name "") - (insert "end;") - (insert "end " ada-block-name ";")) - ) - (end-of-line -2) - (ada-tab)) - -(defun ada-exception-block () - "Insert a block with an exception part. -Indent for the first line of code." - (interactive) - (let ((block-name (read-string "[block name]: "))) - (insert "begin") - (cond - ( (not (string-equal block-name "")) - (beginning-of-line) - (open-line 1) - (insert block-name ":") - (next-line 1) - (end-of-line))) - (ada-newline) - (ada-newline) - (insert "exception") - (ada-newline) - (ada-newline) - (cond - ( (string-equal block-name "") - (insert "end;")) - ( t - (insert "end " block-name ";"))) - ) - (end-of-line -2) - (ada-tab)) - -(defun ada-exception () - "Insert an indented exception part into a block." - (interactive) - (ada-untab) - (insert "exception") - (ada-newline) - (ada-tab)) - -(defun ada-else () - "Add an else clause inside an if-then-end-if clause." - (interactive) - (ada-untab) - (insert "else") - (ada-newline) - (ada-tab)) - -(defun ada-exit () - "Insert an exit statement, prompting for loop name and condition." - (interactive) - (insert "exit") - (let ((ada-loop-name (read-string "[name of loop to exit]: "))) - (if (not (string-equal ada-loop-name "")) (insert " " ada-loop-name))) - (let ((ada-exit-condition (read-string "[exit condition]: "))) - (if (not (string-equal ada-exit-condition "")) - (if (string-match "^ *[Ww][Hh][Ee][Nn] +" ada-exit-condition) - (insert " " ada-exit-condition) - (insert " when " ada-exit-condition)))) - (insert ";")) - -(defun ada-when () - "Start a case statement alternative with a when clause." - (interactive) - (ada-untab) ; we were indented in code for the last alternative. - (insert "when ") - (insert (read-string "'|'-delimited choice list: ") " =>") - (ada-newline) - (ada-tab)) - -(defun ada-for-loop () - "Build a skeleton for-loop statement, prompting for the loop parameters." - (interactive) - (insert "for ") - (let* ((ada-loop-name (read-string "[loop name]: ")) - (ada-loop-is-named (not (string-equal ada-loop-name "")))) - (if ada-loop-is-named - (progn - (beginning-of-line) - (open-line 1) - (insert ada-loop-name ":") - (next-line 1) - (end-of-line 1))) - (insert (read-string "loop variable: ") " in ") - (insert (read-string "range: ") " loop") - (ada-newline) - (ada-newline) - (insert "end loop") - (if ada-loop-is-named (insert " " ada-loop-name)) - (insert ";")) - (end-of-line 0) - (ada-tab)) - -(defun ada-header () - "Insert a comment block containing the module title, author, etc." - (interactive) - (insert "--\n-- Title: \t") - (insert (read-string "Title: ")) - (insert "\n-- Created:\t" (current-time-string)) - (insert "\n-- Author: \t" (user-full-name)) - (insert "\n--\t\t<" (user-login-name) "@" (system-name) ">\n--\n")) - -(defun ada-if () - "Insert skeleton if statment, prompting for a boolean-expression." - (interactive) - (insert "if ") - (insert (read-string "condition: ") " then") - (ada-newline) - (ada-newline) - (insert "end if;") - (end-of-line 0) - (ada-tab)) - -(defun ada-elsif () - "Add an elsif clause to an if statement, prompting for the boolean-expression." - (interactive) - (ada-untab) - (insert "elsif ") - (insert (read-string "condition: ") " then") - (ada-newline) - (ada-tab)) - -(defun ada-loop () - "Insert a skeleton loop statement. The exit statement is added by hand." - (interactive) - (insert "loop ") - (let* ((ada-loop-name (read-string "[loop name]: ")) - (ada-loop-is-named (not (string-equal ada-loop-name "")))) - (if ada-loop-is-named - (progn - (beginning-of-line) - (open-line 1) - (insert ada-loop-name ":") - (forward-line 1) - (end-of-line 1))) - (ada-newline) - (ada-newline) - (insert "end loop") - (if ada-loop-is-named (insert " " ada-loop-name)) - (insert ";")) - (end-of-line 0) - (ada-tab)) - -(defun ada-package-spec () - "Insert a skeleton package specification." - (interactive) - (insert "package ") - (let ((ada-package-name (read-string "package name: " ))) - (insert ada-package-name " is") - (ada-newline) - (ada-newline) - (insert "end " ada-package-name ";") - (end-of-line 0) - (ada-tab))) - -(defun ada-package-body () - "Insert a skeleton package body -- includes a begin statement." - (interactive) - (insert "package body ") - (let ((ada-package-name (read-string "package name: " ))) - (insert ada-package-name " is") - (ada-newline) - (ada-newline) - (insert "begin") - (ada-newline) - (insert "end " ada-package-name ";") - (end-of-line -1) - (ada-tab))) - -(defun ada-private () - "Undent and start a private section of a package spec. Reindent." - (interactive) - (ada-untab) - (insert "private") - (ada-newline) - (ada-tab)) - -(defun ada-get-arg-list () - "Read from the user a procedure or function argument list. -Add parens unless arguments absent, and insert into buffer. -Individual arguments are arranged vertically if entered one at a time. -Arguments ending with `;' are presumed single and stacked." - (insert " (") - (let ((ada-arg-indent (current-column)) - (ada-args (read-string "[arguments]: "))) - (if (string-equal ada-args "") - (backward-delete-char 2) - (progn - (while (string-match ";$" ada-args) - (insert ada-args) - (newline) - (indent-to ada-arg-indent) - (setq ada-args (read-string "next argument: "))) - (insert ada-args ")"))))) - -(defun ada-function-spec () - "Insert a function specification. Prompts for name and arguments." - (interactive) - (insert "function ") - (insert (read-string "function name: ")) - (ada-get-arg-list) - (insert " return ") - (insert (read-string "result type: "))) - -(defun ada-procedure-spec () - "Insert a procedure specification, prompting for its name and arguments." - (interactive) - (insert "procedure ") - (insert (read-string "procedure name: " )) - (ada-get-arg-list)) - -(defun get-ada-subprogram-name () - "Return (without moving point or mark) a pair whose CAR is the name of -the function or procedure whose spec immediately precedes point, and whose -CDR is the column number where the procedure/function keyword was found." - (save-excursion - (let ((ada-proc-indent 0)) - (if (re-search-backward - ;;;; Unfortunately, comments are not ignored in this string search. - "[PpFf][RrUu][OoNn][Cc][EeTt][DdIi][UuOo][RrNn]" nil t) - (if (or (looking-at "\\<[Pp][Rr][Oo][Cc][Ee][Dd][Uu][Rr][Ee]\\>") - (looking-at "\\<[Ff][Uu][Nn][Cc][Tt][Ii][Oo][Nn]\\>")) - (progn - (setq ada-proc-indent (current-column)) - (forward-word 2) - (let ((p2 (point))) - (forward-word -1) - (cons (buffer-substring (point) p2) ada-proc-indent))) - (get-ada-subprogram-name)) - (cons "NAME?" ada-proc-indent))))) - -(defun ada-subprogram-body () - "Insert frame for subprogram body. -Invoke right after `ada-function-spec' or `ada-procedure-spec'." - (interactive) - (insert " is") - (let ((ada-subprogram-name-col (get-ada-subprogram-name))) - (newline) - (indent-to (cdr ada-subprogram-name-col)) - (ada-newline) - (insert "begin") - (ada-newline) - (ada-newline) - (insert "end " (car ada-subprogram-name-col) ";")) - (end-of-line -2) - (ada-tab)) - -(defun ada-separate () - "Finish a body stub with `is separate'." - (interactive) - (insert " is") - (ada-newline) - (ada-tab) - (insert "separate;") - (ada-newline) - (ada-untab)) - -;(defun ada-with () -; "Inserts a with clause, prompting for the list of units depended upon." -; (interactive) -; (insert "with ") -; (insert (read-string "list of units depended upon: ") ";")) -; -;(defun ada-use () -; "Inserts a use clause, prompting for the list of packages used." -; (interactive) -; (insert "use ") -; (insert (read-string "list of packages to use: ") ";")) - -(defun ada-record () - "Insert a skeleton record type declaration." - (interactive) - (insert "record") - (ada-newline) - (ada-newline) - (insert "end record;") - (end-of-line 0) - (ada-tab)) - -(defun ada-subtype () - "Start insertion of a subtype declaration, prompting for the subtype name." - (interactive) - (insert "subtype " (read-string "subtype name: ") " is ;") - (backward-char) - (message "insert subtype indication.")) - -(defun ada-type () - "Start insertion of a type declaration, prompting for the type name." - (interactive) - (insert "type " (read-string "type name: ")) - (let ((disc-part (read-string "discriminant specs: "))) - (if (not (string-equal disc-part "")) - (insert "(" disc-part ")"))) - (insert " is ") - (message "insert type definition.")) - -(defun ada-while-loop () - (interactive) - (insert "while ") - (let* ((ada-loop-name (read-string "loop name: ")) - (ada-loop-is-named (not (string-equal ada-loop-name "")))) - (if ada-loop-is-named - (progn - (beginning-of-line) - (open-line 1) - (insert ada-loop-name ":") - (next-line 1) - (end-of-line 1))) - (insert (read-string "entry condition: ") " loop") - (ada-newline) - (ada-newline) - (insert "end loop") - (if ada-loop-is-named (insert " " ada-loop-name)) - (insert ";")) - (end-of-line 0) - (ada-tab)) - -(defun ada-paired-parens () - "Insert a pair of round parentheses, placing point between them." - (interactive) - (insert "()") - (backward-char)) - -(defun ada-inline-comment () - "Start a comment after the end of the line, indented at least -`comment-column' spaces. If starting after `end-comment-column', -start a new line." - (interactive) - (end-of-line) - (if (> (current-column) ada-comment-end-column) (newline)) - (if (< (current-column) comment-column) (indent-to comment-column)) - (insert " -- ")) - -(defun ada-display-comment () -"Inserts three comment lines, making a display comment." - (interactive) - (insert "--\n-- \n--") - (end-of-line 0)) - -;; Much of this is specific to Ada-Ed - -(defvar ada-lib-dir-name "lib" "*Current Ada program library directory.") -(defvar ada-bind-opts "" "*Options to supply for binding.") - -(defun ada-library-name (ada-lib-name) - "Specify name of Ada library directory for later compilations." - (interactive "DName of Ada library directory: ") - (setq ada-lib-dir-name ada-lib-name)) - -(defun ada-options-for-bind () - "Specify options, such as -m and -i, needed for `ada-bind'." - (setq ada-bind-opts (read-string "-m and -i options for `ada-bind': "))) - -(defun ada-compile (arg) - "Save the current buffer and compile it into the current program library. -Initialize the library if a prefix arg is given." - (interactive "P") - (let* ((ada-init (if (null arg) "" "-n ")) - (ada-source-file (buffer-name))) - (compile - (concat "adacomp " ada-init "-l " ada-lib-dir-name " " ada-source-file)))) - -(defun ada-find-listing () - "Find listing file for ada source in current buffer, using other window." - (interactive) - (find-file-other-window (concat (substring (buffer-name) 0 -4) ".lis")) - (search-forward "*** ERROR")) - -(defun ada-bind () - "Bind the current program library, using the current binding options." - (interactive) - (compile (concat "adabind " ada-bind-opts " " ada-lib-dir-name))) - -;;; ada.el ends here
--- a/lisp/=batmode.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,165 +0,0 @@ -;;; batmode.el --- Simple mode for Windows BAT files - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: Peter Breton <pbreton@i-kinetics.com> -;; Created: Thu Jul 25 1996 -;; Keywords: BAT, DOS, Windows - -;; 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: -;; -;; USAGE: Byte-compile this file, and add the following lines to your -;; emacs initialization file (.emacs/_emacs): -;; -;; (setq auto-mode-alist -;; (append -;; (list (cons "\\.[bB][aA][tT]$" 'bat-mode)) -;; ;; For DOS init files -;; (list (cons "CONFIG\\." 'bat-mode)) -;; (list (cons "AUTOEXEC\\." 'bat-mode)) -;; auto-mode-alist)) -;; -;; (autoload 'bat-mode "batmode" -;; "DOS and WIndows BAT files" t) - -;; TODO: -;; -;; Support "compiles" ? -;; Imenu? Don't have real functions..... - -;;; Change log: -;; $Log: batmode.el,v $ -;; Revision 1.3 1996/08/22 02:31:47 peter -;; Added Usage message, credit to folks from NTEmacs mailing list, -;; Syntax table, New font-lock keywords -;; -;; Revision 1.2 1996/08/18 16:27:13 peter -;; Added preliminary global-font-lock support -;; -;; Revision 1.1 1996/08/18 16:14:18 peter -;; Initial revision -;; - -;; Credit for suggestions, patches and bug-fixes: -;; Robert Brodersen <rbrodersen@siebel.com> -;; ACorreir@pervasive-sw.com (Alfred Correira) - -;;; Code: - -(defvar bat-mode-map nil "Local keymap for bat-mode buffers.") - -;; Make this lowercase if you like -(defvar bat-mode-comment-start "REM " - "Comment string to use in BAT mode") - -(defvar bat-mode-syntax-table nil - "Syntax table in use in Bat-mode buffers.") - -(if bat-mode-map - nil - (setq bat-mode-map (copy-keymap global-map)) -) - -;; Make underscores count as words -(if bat-mode-syntax-table - () - (setq bat-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?_ "w" bat-mode-syntax-table) -) - -(defun bat-mode () - "Mode for DOS and Windows BAT files" - (interactive) - (kill-all-local-variables) - (use-local-map bat-mode-map) - (set-syntax-table bat-mode-syntax-table) - - (make-local-variable 'parse-sexp-ignore-comments) - (make-local-variable 'comment-start) - (make-local-variable 'comment-start-skip) - (make-local-variable 'comment-end) - (make-local-variable 'executable-command) - (make-local-variable 'font-lock-defaults) - - (setq major-mode 'bat-mode - mode-name "bat" - - comment-end "" - - comment-start bat-mode-comment-start - comment-start-skip "[Rr][Ee][Mm] *" - - parse-sexp-ignore-comments t - - ) - - ;; Global font-lock support - ;; (setq font-lock-defaults (list 'bat-font-lock-keywords nil t nil nil)) - (setq font-lock-defaults (list 'bat-font-lock-keywords nil)) - - (run-hooks 'bat-mode-hook)) - -(defvar bat-font-lock-keywords - (list - ;; Make this one first in the list, otherwise comments will - ;; be over-written by other variables - (list "^[@ \t]*\\([rR][eE][mM].*\\)" 1 'font-lock-comment-face t) - (list "^[ \t]*\\(::-.*\\)" 1 'font-lock-comment-face t) - (list - (concat "\\(\\<" - (mapconcat 'identity - '( - "call" - "echo" - "exist" - "errorlevel" - "for" - "goto" - "if" - "not" - "path" - "pause" - "prompt" - "set" - "start" - ) - "\\>\\|\\<") - "\\>\\)") 1 'font-lock-keyword-face) - (list "^[ \t]*\\(:\\sw+\\)" 1 'font-lock-function-name-face t) - (list "\\(%\\sw+%\\)" 1 'font-lock-reference-face) - (list "\\(%[0-9]\\)" 1 'font-lock-reference-face) - (list "\\(/[^/ \t\n]+\\)" 1 'font-lock-type-face) - (list "\\<\\(goto\\)\\>[ \t]*\\(\\sw+\\)?" - '(1 font-lock-keyword-face) - '(2 font-lock-function-name-face nil t)) - - ) - "Keywords to hilight in BAT mode") - -;;; don't do it in Win-Emacs -(if (boundp 'font-lock-defaults-alist) - (add-to-list - 'font-lock-defaults-alist - (cons 'bat-mode - (list 'bat-font-lock-keywords nil t nil nil)))) - -(provide 'bat-mode) - -;;; batmode.el ends here
--- a/lisp/=bytecpat.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -;;; bytecpat.el --- do recompilation for Emacs patch files. -;;; This function is used by the patch files to update Emacs releases. - -(defun batch-byte-recompile-emacs () - "Recompile the Emacs `lisp' directory. -This is used after installing the patches for a new version." - (let ((load-path (list (expand-file-name "lisp")))) - (byte-recompile-directory "lisp"))) - -(defun batch-byte-compile-emacs () - "Compile new files installed in the Emacs `lisp' directory. -This is used after installing the patches for a new version. -It uses the command line arguments to specify the files to compile." - (let ((load-path (list (expand-file-name "lisp")))) - (batch-byte-compile)))
--- a/lisp/=cl.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3162 +0,0 @@ -;;; cl.el --- Common-Lisp extensions for GNU Emacs Lisp. - -;; Copyright (C) 1987, 1988, 1989, 1992 Free Software Foundation, Inc. - -;; Author: Cesar Quiroz <quiroz@cs.rochester.edu> -;; Keywords: extensions - -(defvar cl-version "3.0 07-February-1993") - -;; This file is part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;;; Commentary: - -;;; Notes from Rob Austein on his mods -;; yaya:/usr/u/sra/cl/cl.el, 5-May-1991 16:01:34, sra -;; -;; Slightly hacked copy of cl.el 2.0 beta 27. -;; -;; Various minor performance improvements: -;; a) Don't use MAPCAR when we're going to discard its results. -;; b) Make various macros a little more clever about optimizing -;; generated code in common cases. -;; c) Fix DEFSETF to expand to the right code at compile-time. -;; d) Make various macros cleverer about generating reasonable -;; code when compiled, particularly forms like DEFSTRUCT which -;; are usually used at top-level and thus are only compiled if -;; you use Hallvard Furuseth's hacked bytecomp.el. -;; -;; New features: GETF, REMF, and REMPROP. -;; -;; Notes: -;; 1) I'm sceptical about the FBOUNDP checks in SETF. Why should -;; the SETF expansion fail because the SETF method isn't defined -;; at compile time? Lisp is going to check for a binding at run-time -;; anyway, so maybe we should just assume the user's right here. - -;;;; These are extensions to Emacs Lisp that provide some form of -;;;; Common Lisp compatibility, beyond what is already built-in -;;;; in Emacs Lisp. -;;;; -;;;; When developing them, I had the code spread among several files. -;;;; This file 'cl.el' is a concatenation of those original files, -;;;; minus some declarations that became redundant. The marks between -;;;; the original files can be found easily, as they are lines that -;;;; begin with four semicolons (as this does). The names of the -;;;; original parts follow the four semicolons in uppercase, those -;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS, -;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT. If you -;;;; add functions to this file, you might want to put them in a place -;;;; that is compatible with the division above (or invent your own -;;;; categories). -;;;; -;;;; To compile this file, make sure you load it first. This is -;;;; because many things are implemented as macros and now that all -;;;; the files are concatenated together one cannot ensure that -;;;; declaration always precedes use. -;;;; -;;;; Bug reports, suggestions and comments, -;;;; to quiroz@cs.rochester.edu - - -;;;; GLOBAL -;;;; This file provides utilities and declarations that are global -;;;; to Common Lisp and so might be used by more than one of the -;;;; other libraries. Especially, I intend to keep here some -;;;; utilities that help parsing/destructuring some difficult calls. -;;;; -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; Too many pieces of the rest of this package use psetq. So it is unwise to -;;; use here anything but plain Emacs Lisp! There is a neater recursive form -;;; for the algorithm that deals with the bodies. - -;;; Code: - -;;; This version is due to Hallvard Furuseth (hallvard@ifi.uio.no, 6 Jul 91) -(defmacro psetq (&rest args) - "(psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE. -All the VALUEs are evaluated, and then all the VARIABLEs are set. -Aside from order of evaluation, this is the same as `setq'." - ;; check there is a reasonable number of forms - (if (/= (% (length args) 2) 0) - (error "Odd number of arguments to `psetq'")) - (setq args (copy-sequence args)) ;for safety below - (prog1 (cons 'setq args) - (while (progn (if (not (symbolp (car args))) - (error "`psetq' expected a symbol, found '%s'." - (prin1-to-string (car args)))) - (cdr (cdr args))) - (setcdr args (list (list 'prog1 (nth 1 args) - (cons 'setq - (setq args (cdr (cdr args)))))))))) - -;;; utilities -;;; -;;; pair-with-newsyms takes a list and returns a list of lists of the -;;; form (newsym form), such that a let* can then bind the evaluation -;;; of the forms to the newsyms. The idea is to guarantee correct -;;; order of evaluation of the subforms of a setf. It also returns a -;;; list of the newsyms generated, in the corresponding order. - -(defun pair-with-newsyms (oldforms) - "PAIR-WITH-NEWSYMS OLDFORMS -The top-level components of the list oldforms are paired with fresh -symbols, the pairings list and the newsyms list are returned." - (do ((ptr oldforms (cdr ptr)) - (bindings '()) - (newsyms '())) - ((endp ptr) (values (nreverse bindings) (nreverse newsyms))) - (let ((newsym (gentemp))) - (setq bindings (cons (list newsym (car ptr)) bindings)) - (setq newsyms (cons newsym newsyms))))) - -(defun zip-lists (evens odds) - "Merge two lists EVENS and ODDS, taking elts from each list alternatingly. -EVENS and ODDS are two lists. ZIP-LISTS constructs a new list, whose -even numbered elements (0,2,...) come from EVENS and whose odd -numbered elements (1,3,...) come from ODDS. -The construction stops when the shorter list is exhausted." - (do* ((p0 evens (cdr p0)) - (p1 odds (cdr p1)) - (even (car p0) (car p0)) - (odd (car p1) (car p1)) - (result '())) - ((or (endp p0) (endp p1)) - (nreverse result)) - (setq result - (cons odd (cons even result))))) - -(defun unzip-list (list) - "Extract even and odd elements of LIST into two separate lists. -The argument LIST is separated in two strands, the even and the odd -numbered elements. Numbering starts with 0, so the first element -belongs in EVENS. No check is made that there is an even number of -elements to start with." - (do* ((ptr list (cddr ptr)) - (this (car ptr) (car ptr)) - (next (cadr ptr) (cadr ptr)) - (evens '()) - (odds '())) - ((endp ptr) - (values (nreverse evens) (nreverse odds))) - (setq evens (cons this evens)) - (setq odds (cons next odds)))) - -(defun reassemble-argslists (argslists) - "(reassemble-argslists ARGSLISTS) => a list of lists -ARGSLISTS is a list of sequences. Return a list of lists, the first -sublist being all the entries coming from ELT 0 of the original -sublists, the next those coming from ELT 1 and so on, until the -shortest list is exhausted." - (let* ((minlen (apply 'min (mapcar 'length argslists))) - (result '())) - (dotimes (i minlen (nreverse result)) - ;; capture all the elements at index i - (setq result - (cons (mapcar (function (lambda (sublist) (elt sublist i))) - argslists) - result))))) - - -;;; Checking that a list of symbols contains no duplicates is a common -;;; task when checking the legality of some macros. The check for 'eq -;;; pairs can be too expensive, as it is quadratic on the length of -;;; the list. I use a 4-pass, linear, counting approach. It surely -;;; loses on small lists (less than 5 elements?), but should win for -;;; larger lists. The fourth pass could be eliminated. -;;; 10 dec 1986. Emacs Lisp has no REMPROP, so I just eliminated the -;;; 4th pass. -;;; -;;; [22 April 1991, sra] REMPROP now in library, so restored 4th pass. -(defun duplicate-symbols-p (list) - "Find all symbols appearing more than once in LIST. -Return a list of all such duplicates; `nil' if there are no duplicates." - (let ((duplicates '()) ;result built here - (propname (gensym)) ;we use a fresh property - ) - ;; check validity - (unless (and (listp list) - (every 'symbolp list)) - (error "a list of symbols is needed")) - ;; pass 1: mark - (dolist (x list) - (put x propname 0)) - ;; pass 2: count - (dolist (x list) - (put x propname (1+ (get x propname)))) - ;; pass 3: collect - (dolist (x list) - (if (> (get x propname) 1) - (setq duplicates (cons x duplicates)))) - ;; pass 4: unmark. - (dolist (x list) - (remprop x propname)) - ;; return result - duplicates)) - -;;;; end of cl-global.el - -;;;; SYMBOLS -;;;; This file provides the gentemp function, which generates fresh -;;;; symbols, plus some other minor Common Lisp symbol tools. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; Keywords. There are no packages in Emacs Lisp, so this is only a -;;; kludge around to let things be "as if" a keyword package was around. - -(defmacro defkeyword (x &optional docstring) - "Make symbol X a keyword (symbol whose value is itself). -Optional second argument is a documentation string for it." - (cond ((symbolp x) - (list 'defconst x (list 'quote x) docstring)) - (t - (error "`%s' is not a symbol" (prin1-to-string x))))) - -(defun keywordp (sym) - "t if SYM is a keyword." - (if (and (symbolp sym) (char-equal (aref (symbol-name sym) 0) ?\:)) - ;; looks like one, make sure value is right - (set sym sym) - nil)) - -(defun keyword-of (sym) - "Return a keyword that is naturally associated with symbol SYM. -If SYM is keyword, the value is SYM. -Otherwise it is a keyword whose name is `:' followed by SYM's name." - (cond ((keywordp sym) - sym) - ((symbolp sym) - (let ((newsym (intern (concat ":" (symbol-name sym))))) - (set newsym newsym))) - (t - (error "expected a symbol, not `%s'" (prin1-to-string sym))))) - -;;; Temporary symbols. -;;; - -(defvar *gentemp-index* 0 - "Integer used by gentemp to produce new names.") - -(defvar *gentemp-prefix* "T$$_" - "Names generated by gentemp begin with this string by default.") - -(defun gentemp (&optional prefix oblist) - "Generate a fresh interned symbol. -There are 2 optional arguments, PREFIX and OBLIST. PREFIX is the -string that begins the new name, OBLIST is the obarray used to search for -old names. The defaults are just right, YOU SHOULD NEVER NEED THESE -ARGUMENTS IN YOUR OWN CODE." - (if (null prefix) - (setq prefix *gentemp-prefix*)) - (if (null oblist) - (setq oblist obarray)) ;default for the intern functions - (let ((newsymbol nil) - (newname)) - (while (not newsymbol) - (setq newname (concat prefix *gentemp-index*)) - (setq *gentemp-index* (+ *gentemp-index* 1)) - (if (not (intern-soft newname oblist)) - (setq newsymbol (intern newname oblist)))) - newsymbol)) - -(defvar *gensym-index* 0 - "Integer used by gensym to produce new names.") - -(defvar *gensym-prefix* "G$$_" - "Names generated by gensym begin with this string by default.") - -(defun gensym (&optional prefix) - "Generate a fresh uninterned symbol. -There is an optional argument, PREFIX. PREFIX is the -string that begins the new name. Most people take just the default, -except when debugging needs suggest otherwise." - (if (null prefix) - (setq prefix *gensym-prefix*)) - (let ((newsymbol nil) - (newname "")) - (while (not newsymbol) - (setq newname (concat prefix *gensym-index*)) - (setq *gensym-index* (+ *gensym-index* 1)) - (if (not (intern-soft newname)) - (setq newsymbol (make-symbol newname)))) - newsymbol)) - -;;;; end of cl-symbols.el - -;;;; CONDITIONALS -;;;; This file provides some of the conditional constructs of -;;;; Common Lisp. Total compatibility is again impossible, as the -;;;; 'if' form is different in both languages, so only a good -;;;; approximation is desired. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; indentation info -(put 'case 'lisp-indent-hook 1) -(put 'ecase 'lisp-indent-hook 1) -(put 'when 'lisp-indent-hook 1) -(put 'unless 'lisp-indent-hook 1) - -;;; WHEN and UNLESS -;;; These two forms are simplified ifs, with a single branch. - -(defmacro when (condition &rest body) - "(when CONDITION . BODY) => evaluate BODY if CONDITION is true." - (list* 'if (list 'not condition) '() body)) - -(defmacro unless (condition &rest body) - "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false." - (list* 'if condition '() body)) - -;;; CASE and ECASE -;;; CASE selects among several clauses, based on the value (evaluated) -;;; of a expression and a list of (unevaluated) key values. ECASE is -;;; the same, but signals an error if no clause is activated. - -(defmacro case (expr &rest cases) - "(case EXPR . CASES) => evals EXPR, chooses from CASES on that value. -EXPR -> any form -CASES -> list of clauses, non empty -CLAUSE -> HEAD . BODY -HEAD -> t = catch all, must be last clause - -> otherwise = same as t - -> nil = illegal - -> atom = activated if (eql EXPR HEAD) - -> list of atoms = activated if (memq EXPR HEAD) -BODY -> list of forms, implicit PROGN is built around it. -EXPR is evaluated only once." - (let* ((newsym (gentemp)) - (clauses (case-clausify cases newsym))) - ;; convert case into a cond inside a let - (list 'let - (list (list newsym expr)) - (list* 'cond (nreverse clauses))))) - -(defmacro ecase (expr &rest cases) - "(ecase EXPR . CASES) => like `case', but error if no case fits. -`t'-clauses are not allowed." - (let* ((newsym (gentemp)) - (clauses (case-clausify cases newsym))) - ;; check that no 't clause is present. - ;; case-clausify would put one such at the beginning of clauses - (if (eq (caar clauses) t) - (error "no clause-head should be `t' or `otherwise' for `ecase'")) - ;; insert error-catching clause - (setq clauses - (cons - (list 't (list 'error - "ecase on %s = %s failed to take any branch" - (list 'quote expr) - (list 'prin1-to-string newsym))) - clauses)) - ;; generate code as usual - (list 'let - (list (list newsym expr)) - (list* 'cond (nreverse clauses))))) - - -(defun case-clausify (cases newsym) - "CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond' -Converts the CASES of a [e]case macro into cond clauses to be -evaluated inside a let that binds NEWSYM. Returns the clauses in -reverse order." - (do* ((currentpos cases (cdr currentpos)) - (nextpos (cdr cases) (cdr nextpos)) - (curclause (car cases) (car currentpos)) - (result '())) - ((endp currentpos) result) - (let ((head (car curclause)) - (body (cdr curclause))) - ;; construct a cond-clause according to the head - (cond ((null head) - (error "case clauses cannot have null heads: `%s'" - (prin1-to-string curclause))) - ((or (eq head 't) - (eq head 'otherwise)) - ;; check it is the last clause - (if (not (endp nextpos)) - (error "clause with `t' or `otherwise' head must be last")) - ;; accept this clause as a 't' for cond - (setq result (cons (cons 't body) result))) - ((atom head) - (setq result - (cons (cons (list 'eql newsym (list 'quote head)) body) - result))) - ((listp head) - (setq result - (cons (cons (list 'memq newsym (list 'quote head)) body) - result))) - (t - ;; catch-all for this parser - (error "don't know how to parse case clause `%s'" - (prin1-to-string head))))))) - -;;;; end of cl-conditionals.el - -;;;; ITERATIONS -;;;; This file provides simple iterative macros (a la Common Lisp) -;;;; constructed on the basis of let, let* and while, which are the -;;;; primitive binding/iteration constructs of Emacs Lisp -;;;; -;;;; The Common Lisp iterations use to have a block named nil -;;;; wrapped around them, and allow declarations at the beginning -;;;; of their bodies and you can return a value using (return ...). -;;;; Nothing of the sort exists in Emacs Lisp, so I haven't tried -;;;; to imitate these behaviors. -;;;; -;;;; Other than the above, the semantics of Common Lisp are -;;;; correctly reproduced to the extent this was reasonable. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; some lisp-indentation information -(put 'do 'lisp-indent-hook 2) -(put 'do* 'lisp-indent-hook 2) -(put 'dolist 'lisp-indent-hook 1) -(put 'dotimes 'lisp-indent-hook 1) -(put 'do-symbols 'lisp-indent-hook 1) -(put 'do-all-symbols 'lisp-indent-hook 1) - - -(defmacro do (stepforms endforms &rest body) - "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables. -STEPFORMS must be a list of symbols or lists. In the second case, the -lists must start with a symbol and contain up to two more forms. In -the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms -are the initial value (def. NIL) and the form to step (def. itself). -The values used by initialization and stepping are computed in parallel. -The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION -evaluates to true in any iteration, ENDBODY is evaluated and the last -form in it is returned. -The BODY (which may be empty) is evaluated at every iteration, with -the symbols of the STEPFORMS bound to the initial or stepped values." - ;; check the syntax of the macro - (and (check-do-stepforms stepforms) - (check-do-endforms endforms)) - ;; construct emacs-lisp equivalent - (let ((initlist (extract-do-inits stepforms)) - (steplist (extract-do-steps stepforms)) - (endcond (car endforms)) - (endbody (cdr endforms))) - (cons 'let (cons initlist - (cons (cons 'while (cons (list 'not endcond) - (append body steplist))) - (append endbody)))))) - - -(defmacro do* (stepforms endforms &rest body) - "`do*' is to `do' as `let*' is to `let'. -STEPFORMS must be a list of symbols or lists. In the second case, the -lists must start with a symbol and contain up to two more forms. In -the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms -are the initial value (def. NIL) and the form to step (def. itself). -Initializations and steppings are done in the sequence they are written. -The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION -evaluates to true in any iteration, ENDBODY is evaluated and the last -form in it is returned. -The BODY (which may be empty) is evaluated at every iteration, with -the symbols of the STEPFORMS bound to the initial or stepped values." - ;; check the syntax of the macro - (and (check-do-stepforms stepforms) - (check-do-endforms endforms)) - ;; construct emacs-lisp equivalent - (let ((initlist (extract-do-inits stepforms)) - (steplist (extract-do*-steps stepforms)) - (endcond (car endforms)) - (endbody (cdr endforms))) - (cons 'let* (cons initlist - (cons (cons 'while (cons (list 'not endcond) - (append body steplist))) - (append endbody)))))) - - -;;; DO and DO* share the syntax checking functions that follow. - -(defun check-do-stepforms (forms) - "True if FORMS is a valid stepforms for the do[*] macro (q.v.)" - (if (nlistp forms) - (error "init/step form for do[*] should be a list, not `%s'" - (prin1-to-string forms)) - (mapcar - (function - (lambda (entry) - (if (not (or (symbolp entry) - (and (listp entry) - (symbolp (car entry)) - (< (length entry) 4)))) - (error "init/step must be %s, not `%s'" - "symbol or (symbol [init [step]])" - (prin1-to-string entry))))) - forms))) - -(defun check-do-endforms (forms) - "True if FORMS is a valid endforms for the do[*] macro (q.v.)" - (if (nlistp forms) - (error "termination form for do macro should be a list, not `%s'" - (prin1-to-string forms)))) - -(defun extract-do-inits (forms) - "Returns a list of the initializations (for do) in FORMS ---a stepforms, see the do macro--. FORMS is assumed syntactically valid." - (mapcar - (function - (lambda (entry) - (cond ((symbolp entry) - (list entry nil)) - ((listp entry) - (list (car entry) (cadr entry)))))) - forms)) - -;;; There used to be a reason to deal with DO differently than with -;;; DO*. The writing of PSETQ has made it largely unnecessary. - -(defun extract-do-steps (forms) - "EXTRACT-DO-STEPS FORMS => an s-expr -FORMS is the stepforms part of a DO macro (q.v.). This function -constructs an s-expression that does the stepping at the end of an -iteration." - (list (cons 'psetq (select-stepping-forms forms)))) - -(defun extract-do*-steps (forms) - "EXTRACT-DO*-STEPS FORMS => an s-expr -FORMS is the stepforms part of a DO* macro (q.v.). This function -constructs an s-expression that does the stepping at the end of an -iteration." - (list (cons 'setq (select-stepping-forms forms)))) - -(defun select-stepping-forms (forms) - "Separate only the forms that cause stepping." - (let ((result '()) ;ends up being (... var form ...) - (ptr forms) ;to traverse the forms - entry ;to explore each form in turn - ) - (while ptr ;(not (endp entry)) might be safer - (setq entry (car ptr)) - (cond ((and (listp entry) (= (length entry) 3)) - (setq result (append ;append in reverse order! - (list (caddr entry) (car entry)) - result)))) - (setq ptr (cdr ptr))) ;step in the list of forms - (nreverse result))) - -;;; Other iterative constructs - -(defmacro dolist (stepform &rest body) - "(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST. -The RESULTFORM defaults to nil. The VAR is bound to successive -elements of the value of LIST and remains bound (to the nil value) when the -RESULTFORM is evaluated." - ;; check sanity - (cond - ((nlistp stepform) - (error "stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'" - (prin1-to-string stepform))) - ((not (symbolp (car stepform))) - (error "first component of stepform should be a symbol, not `%s'" - (prin1-to-string (car stepform)))) - ((> (length stepform) 3) - (error "too many components in stepform `%s'" - (prin1-to-string stepform)))) - ;; generate code - (let* ((var (car stepform)) - (listform (cadr stepform)) - (resultform (caddr stepform)) - (listsym (gentemp))) - (nconc - (list 'let (list var (list listsym listform)) - (nconc - (list 'while listsym - (list 'setq - var (list 'car listsym) - listsym (list 'cdr listsym))) - body)) - (and resultform - (cons (list 'setq var nil) - (list resultform)))))) - -(defmacro dotimes (stepform &rest body) - "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR. -The COUNTFORM should return a positive integer. The VAR is bound to -successive integers from 0 to COUNTFORM-1 and the BODY is repeated for -each of them. At the end, the RESULTFORM is evaluated and its value -returned. During this last evaluation, the VAR is still bound, and its -value is the number of times the iteration occurred. An omitted RESULTFORM -defaults to nil." - ;; check sanity - (cond - ((nlistp stepform) - (error "stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'" - (prin1-to-string stepform))) - ((not (symbolp (car stepform))) - (error "first component of stepform should be a symbol, not `%s'" - (prin1-to-string (car stepform)))) - ((> (length stepform) 3) - (error "too many components in stepform `%s'" - (prin1-to-string stepform)))) - ;; generate code - (let* ((var (car stepform)) - (countform (cadr stepform)) - (resultform (caddr stepform)) - (testsym (if (consp countform) (gentemp) countform))) - (nconc - (list - 'let (cons (list var -1) - (and (not (eq countform testsym)) - (list (list testsym countform)))) - (nconc - (list 'while (list '< (list 'setq var (list '1+ var)) testsym)) - body)) - (and resultform (list resultform))))) - -(defmacro do-symbols (stepform &rest body) - "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY) -The VAR is bound to each of the symbols in OBARRAY (def. obarray) and -the BODY is repeatedly performed for each of those bindings. At the -end, RESULTFORM (def. nil) is evaluated and its value returned. -During this last evaluation, the VAR is still bound and its value is nil. -See also the function `mapatoms'." - ;; check sanity - (cond - ((nlistp stepform) - (error "stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'" - (prin1-to-string stepform))) - ((not (symbolp (car stepform))) - (error "first component of stepform should be a symbol, not `%s'" - (prin1-to-string (car stepform)))) - ((> (length stepform) 3) - (error "too many components in stepform `%s'" - (prin1-to-string stepform)))) - ;; generate code - (let* ((var (car stepform)) - (oblist (cadr stepform)) - (resultform (caddr stepform))) - (list 'progn - (list 'mapatoms - (list 'function - (cons 'lambda (cons (list var) body))) - oblist) - (list 'let - (list (list var nil)) - resultform)))) - - -(defmacro do-all-symbols (stepform &rest body) - "(do-all-symbols (VAR [RESULTFORM]) . BODY) -Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)." - (list* - 'do-symbols - (list (car stepform) 'obarray (cadr stepform)) - body)) - -(defmacro loop (&rest body) - "(loop . BODY) repeats BODY indefinitely and does not return. -Normally BODY uses `throw' or `signal' to cause an exit. -The forms in BODY should be lists, as non-lists are reserved for new features." - ;; check that the body doesn't have atomic forms - (if (nlistp body) - (error "body of `loop' should be a list of lists or nil") - ;; ok, it is a list, check for atomic components - (mapcar - (function (lambda (component) - (if (nlistp component) - (error "components of `loop' should be lists")))) - body) - ;; build the infinite loop - (cons 'while (cons 't body)))) - -;;;; end of cl-iterations.el - -;;;; LISTS -;;;; This file provides some of the lists machinery of Common-Lisp -;;;; in a way compatible with Emacs Lisp. Especially, see the the -;;;; typical c[ad]*r functions. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; Synonyms for list functions -(defsubst first (x) - "Synonym for `car'" - (car x)) - -(defsubst second (x) - "Return the second element of the list LIST." - (nth 1 x)) - -(defsubst third (x) - "Return the third element of the list LIST." - (nth 2 x)) - -(defsubst fourth (x) - "Return the fourth element of the list LIST." - (nth 3 x)) - -(defsubst fifth (x) - "Return the fifth element of the list LIST." - (nth 4 x)) - -(defsubst sixth (x) - "Return the sixth element of the list LIST." - (nth 5 x)) - -(defsubst seventh (x) - "Return the seventh element of the list LIST." - (nth 6 x)) - -(defsubst eighth (x) - "Return the eighth element of the list LIST." - (nth 7 x)) - -(defsubst ninth (x) - "Return the ninth element of the list LIST." - (nth 8 x)) - -(defsubst tenth (x) - "Return the tenth element of the list LIST." - (nth 9 x)) - -(defsubst rest (x) - "Synonym for `cdr'" - (cdr x)) - -(defsubst endp (x) - "t if X is nil, nil if X is a cons; error otherwise." - (if (listp x) - (null x) - (error "endp received a non-cons, non-null argument `%s'" - (prin1-to-string x)))) - -(defun last (x) - "Returns the last link in the list LIST." - (if (nlistp x) - (error "arg to `last' must be a list")) - (do ((current-cons x (cdr current-cons)) - (next-cons (cdr x) (cdr next-cons))) - ((endp next-cons) current-cons))) - -(defun list-length (x) ;taken from CLtL sect. 15.2 - "Returns the length of a non-circular list, or `nil' for a circular one." - (do ((n 0) ;counter - (fast x (cddr fast)) ;fast pointer, leaps by 2 - (slow x (cdr slow)) ;slow pointer, leaps by 1 - (ready nil)) ;indicates termination - (ready n) - (cond ((endp fast) - (setq ready t)) ;return n - ((endp (cdr fast)) - (setq n (+ n 1)) - (setq ready t)) ;return n+1 - ((and (eq fast slow) (> n 0)) - (setq n nil) - (setq ready t)) ;return nil - (t - (setq n (+ n 2)))))) ;just advance counter - -(defun butlast (list &optional n) - "Return a new list like LIST but sans the last N elements. -N defaults to 1. If the list doesn't have N elements, nil is returned." - (if (null n) (setq n 1)) - (nreverse (nthcdr n (reverse list)))) ;optim. due to macrakis@osf.org - -;;; This version due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) -(defun list* (arg &rest others) - "Return a new list containing the first arguments consed onto the last arg. -Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)." - (if (null others) - arg - (let* ((others (cons arg (copy-sequence others))) - (a others)) - (while (cdr (cdr a)) - (setq a (cdr a))) - (setcdr a (car (cdr a))) - others))) - -(defun adjoin (item list) - "Return a list which contains ITEM but is otherwise like LIST. -If ITEM occurs in LIST, the value is LIST. Otherwise it is (cons ITEM LIST). -When comparing ITEM against elements, `eql' is used." - (if (memq item list) - list - (cons item list))) - -(defun ldiff (list sublist) - "Return a new list like LIST but sans SUBLIST. -SUBLIST must be one of the links in LIST; otherwise the value is LIST itself." - (do ((result '()) - (curcons list (cdr curcons))) - ((or (endp curcons) (eq curcons sublist)) - (reverse result)) - (setq result (cons (car curcons) result)))) - -;;; The popular c[ad]*r functions and other list accessors. - -;;; To implement this efficiently, a new byte compile handler is used to -;;; generate the minimal code, saving one function call. - -(defsubst caar (X) - "Return the car of the car of X." - (car (car X))) - -(defsubst cadr (X) - "Return the car of the cdr of X." - (car (cdr X))) - -(defsubst cdar (X) - "Return the cdr of the car of X." - (cdr (car X))) - -(defsubst cddr (X) - "Return the cdr of the cdr of X." - (cdr (cdr X))) - -(defsubst caaar (X) - "Return the car of the car of the car of X." - (car (car (car X)))) - -(defsubst caadr (X) - "Return the car of the car of the cdr of X." - (car (car (cdr X)))) - -(defsubst cadar (X) - "Return the car of the cdr of the car of X." - (car (cdr (car X)))) - -(defsubst cdaar (X) - "Return the cdr of the car of the car of X." - (cdr (car (car X)))) - -(defsubst caddr (X) - "Return the car of the cdr of the cdr of X." - (car (cdr (cdr X)))) - -(defsubst cdadr (X) - "Return the cdr of the car of the cdr of X." - (cdr (car (cdr X)))) - -(defsubst cddar (X) - "Return the cdr of the cdr of the car of X." - (cdr (cdr (car X)))) - -(defsubst cdddr (X) - "Return the cdr of the cdr of the cdr of X." - (cdr (cdr (cdr X)))) - -(defsubst caaaar (X) - "Return the car of the car of the car of the car of X." - (car (car (car (car X))))) - -(defsubst caaadr (X) - "Return the car of the car of the car of the cdr of X." - (car (car (car (cdr X))))) - -(defsubst caadar (X) - "Return the car of the car of the cdr of the car of X." - (car (car (cdr (car X))))) - -(defsubst cadaar (X) - "Return the car of the cdr of the car of the car of X." - (car (cdr (car (car X))))) - -(defsubst cdaaar (X) - "Return the cdr of the car of the car of the car of X." - (cdr (car (car (car X))))) - -(defsubst caaddr (X) - "Return the car of the car of the cdr of the cdr of X." - (car (car (cdr (cdr X))))) - -(defsubst cadadr (X) - "Return the car of the cdr of the car of the cdr of X." - (car (cdr (car (cdr X))))) - -(defsubst cdaadr (X) - "Return the cdr of the car of the car of the cdr of X." - (cdr (car (car (cdr X))))) - -(defsubst caddar (X) - "Return the car of the cdr of the cdr of the car of X." - (car (cdr (cdr (car X))))) - -(defsubst cdadar (X) - "Return the cdr of the car of the cdr of the car of X." - (cdr (car (cdr (car X))))) - -(defsubst cddaar (X) - "Return the cdr of the cdr of the car of the car of X." - (cdr (cdr (car (car X))))) - -(defsubst cadddr (X) - "Return the car of the cdr of the cdr of the cdr of X." - (car (cdr (cdr (cdr X))))) - -(defsubst cddadr (X) - "Return the cdr of the cdr of the car of the cdr of X." - (cdr (cdr (car (cdr X))))) - -(defsubst cdaddr (X) - "Return the cdr of the car of the cdr of the cdr of X." - (cdr (car (cdr (cdr X))))) - -(defsubst cdddar (X) - "Return the cdr of the cdr of the cdr of the car of X." - (cdr (cdr (cdr (car X))))) - -(defsubst cddddr (X) - "Return the cdr of the cdr of the cdr of the cdr of X." - (cdr (cdr (cdr (cdr X))))) - -;;; some inverses of the accessors are needed for setf purposes - -(defsubst setnth (n list newval) - "Set (nth N LIST) to NEWVAL. Returns NEWVAL." - (rplaca (nthcdr n list) newval)) - -(defun setnthcdr (n list newval) - "(setnthcdr N LIST NEWVAL) => NEWVAL -As a side effect, sets the Nth cdr of LIST to NEWVAL." - (when (< n 0) - (error "N must be 0 or greater, not %d" n)) - (while (> n 0) - (setq list (cdr list) - n (- n 1))) - ;; here only if (zerop n) - (rplaca list (car newval)) - (rplacd list (cdr newval)) - newval) - -;;; A-lists machinery - -(defsubst acons (key item alist) - "Return a new alist with KEY paired with ITEM; otherwise like ALIST. -Does not copy ALIST." - (cons (cons key item) alist)) - -(defun pairlis (keys data &optional alist) - "Return a new alist with each elt of KEYS paired with an elt of DATA; -optional 3rd arg ALIST is nconc'd at the end. KEYS and DATA must -have the same length." - (unless (= (length keys) (length data)) - (error "keys and data should be the same length")) - (do* ;;collect keys and data in front of alist - ((kptr keys (cdr kptr)) ;traverses the keys - (dptr data (cdr dptr)) ;traverses the data - (key (car kptr) (car kptr)) ;current key - (item (car dptr) (car dptr)) ;current data item - (result alist)) - ((endp kptr) result) - (setq result (acons key item result)))) - -;;;; end of cl-lists.el - -;;;; SEQUENCES -;;;; Emacs Lisp provides many of the 'sequences' functionality of -;;;; Common Lisp. This file provides a few things that were left out. -;;;; - - -(defkeyword :test "Used to designate positive (selection) tests.") -(defkeyword :test-not "Used to designate negative (rejection) tests.") -(defkeyword :key "Used to designate component extractions.") -(defkeyword :predicate "Used to define matching of sequence components.") -(defkeyword :start "Inclusive low index in sequence") -(defkeyword :end "Exclusive high index in sequence") -(defkeyword :start1 "Inclusive low index in first of two sequences.") -(defkeyword :start2 "Inclusive low index in second of two sequences.") -(defkeyword :end1 "Exclusive high index in first of two sequences.") -(defkeyword :end2 "Exclusive high index in second of two sequences.") -(defkeyword :count "Number of elements to affect.") -(defkeyword :from-end "T when counting backwards.") -(defkeyword :initial-value "For the syntax of #'reduce") - -(defun some (pred seq &rest moreseqs) - "Test PREDICATE on each element of SEQUENCE; is it ever non-nil? -Extra args are additional sequences; PREDICATE gets one arg from each -sequence and we advance down all the sequences together in lock-step. -A sequence means either a list or a vector." - (let ((args (reassemble-argslists (list* seq moreseqs)))) - (do* ((ready nil) ;flag: return when t - (result nil) ;resulting value - (applyval nil) ;result of applying pred once - (remaining args - (cdr remaining)) ;remaining argument sets - (current (car remaining) ;current argument set - (car remaining))) - ((or ready (endp remaining)) result) - (setq applyval (apply pred current)) - (when applyval - (setq ready t) - (setq result applyval))))) - -(defun every (pred seq &rest moreseqs) - "Test PREDICATE on each element of SEQUENCE; is it always non-nil? -Extra args are additional sequences; PREDICATE gets one arg from each -sequence and we advance down all the sequences together in lock-step. -A sequence means either a list or a vector." - (let ((args (reassemble-argslists (list* seq moreseqs)))) - (do* ((ready nil) ;flag: return when t - (result t) ;resulting value - (applyval nil) ;result of applying pred once - (remaining args - (cdr remaining)) ;remaining argument sets - (current (car remaining) ;current argument set - (car remaining))) - ((or ready (endp remaining)) result) - (setq applyval (apply pred current)) - (unless applyval - (setq ready t) - (setq result nil))))) - -(defun notany (pred seq &rest moreseqs) - "Test PREDICATE on each element of SEQUENCE; is it always nil? -Extra args are additional sequences; PREDICATE gets one arg from each -sequence and we advance down all the sequences together in lock-step. -A sequence means either a list or a vector." - (let ((args (reassemble-argslists (list* seq moreseqs)))) - (do* ((ready nil) ;flag: return when t - (result t) ;resulting value - (applyval nil) ;result of applying pred once - (remaining args - (cdr remaining)) ;remaining argument sets - (current (car remaining) ;current argument set - (car remaining))) - ((or ready (endp remaining)) result) - (setq applyval (apply pred current)) - (when applyval - (setq ready t) - (setq result nil))))) - -(defun notevery (pred seq &rest moreseqs) - "Test PREDICATE on each element of SEQUENCE; is it sometimes nil? -Extra args are additional sequences; PREDICATE gets one arg from each -sequence and we advance down all the sequences together in lock-step. -A sequence means either a list or a vector." - (let ((args (reassemble-argslists (list* seq moreseqs)))) - (do* ((ready nil) ;flag: return when t - (result nil) ;resulting value - (applyval nil) ;result of applying pred once - (remaining args - (cdr remaining)) ;remaining argument sets - (current (car remaining) ;current argument set - (car remaining))) - ((or ready (endp remaining)) result) - (setq applyval (apply pred current)) - (unless applyval - (setq ready t) - (setq result t))))) - -;;; More sequence functions that don't need keyword arguments - -(defun concatenate (type &rest sequences) - "(concatenate TYPE &rest SEQUENCES) => a sequence -The sequence returned is of type TYPE (must be 'list, 'string, or 'vector) and -contains the concatenation of the elements of all the arguments, in the order -given." - (let ((sequences (append sequences '(())))) - (case type - (list - (apply (function append) sequences)) - (string - (apply (function concat) sequences)) - (vector - (apply (function vector) (apply (function append) sequences))) - (t - (error "type for concatenate `%s' not 'list, 'string or 'vector" - (prin1-to-string type)))))) - -(defun map (type function &rest sequences) - "(map TYPE FUNCTION &rest SEQUENCES) => a sequence -The FUNCTION is called on each set of elements from the SEQUENCES \(stopping -when the shortest sequence is terminated\) and the results are possibly -returned in a sequence of type TYPE \(one of 'list, 'vector, 'string, or nil\) -giving NIL for TYPE gets rid of the values." - (if (not (memq type (list 'list 'string 'vector nil))) - (error "type for map `%s' not 'list, 'string, 'vector or nil" - (prin1-to-string type))) - (let ((argslists (reassemble-argslists sequences)) - results) - (if (null type) - (while argslists ;don't bother accumulating - (apply function (car argslists)) - (setq argslists (cdr argslists))) - (setq results (mapcar (function (lambda (args) (apply function args))) - argslists)) - (case type - (list - results) - (string - (funcall (function concat) results)) - (vector - (apply (function vector) results)))))) - -;;; an inverse of elt is needed for setf purposes - -(defun setelt (seq n newval) - "In SEQUENCE, set the Nth element to NEWVAL. Returns NEWVAL. -A sequence means either a list or a vector." - (let ((l (length seq))) - (if (or (< n 0) (>= n l)) - (error "N(%d) should be between 0 and %d" n l) - ;; only two cases need be considered valid, as strings are arrays - (cond ((listp seq) - (setnth n seq newval)) - ((arrayp seq) - (aset seq n newval)) - (t - (error "SEQ should be a sequence, not `%s'" - (prin1-to-string seq))))))) - -;;; Testing with keyword arguments. -;;; -;;; Many of the sequence functions use keywords to denote some stylized -;;; form of selecting entries in a sequence. The involved arguments -;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key -;;; marker), then they are passed to build-klist, who -;;; constructs an association list. That association list is used to -;;; test for satisfaction and matching. - -;;; DON'T USE MEMBER, NOR ANY FUNCTION THAT COULD TAKE KEYWORDS HERE!!! - -(defun build-klist (argslist acceptable &optional allow-other-keys) - "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE. -ARGSLIST is a list, presumably the &rest argument of a call, whose -even numbered elements must be keywords. -ACCEPTABLE is a list of keywords, the only ones that are truly acceptable. -The result is an alist containing the arguments named by the keywords -in ACCEPTABLE, or an error is signalled, if something failed. -If the third argument (an optional) is non-nil, other keys are acceptable." - ;; check legality of the arguments, then destructure them - (unless (and (listp argslist) - (evenp (length argslist))) - (error "build-klist: odd number of keyword-args")) - (unless (and (listp acceptable) - (every 'keywordp acceptable)) - (error "build-klist: second arg should be a list of keywords")) - (multiple-value-bind - (keywords forms) - (unzip-list argslist) - (unless (every 'keywordp keywords) - (error "build-klist: expected keywords, found `%s'" - (prin1-to-string keywords))) - (unless (or allow-other-keys - (every (function (lambda (keyword) - (memq keyword acceptable))) - keywords)) - (error "bad keyword[s]: %s not in %s" - (prin1-to-string (mapcan (function (lambda (keyword) - (if (memq keyword acceptable) - nil - (list keyword)))) - keywords)) - (prin1-to-string acceptable))) - (do* ;;pick up the pieces - ((auxlist ;auxiliary a-list, may - (pairlis keywords forms)) ;contain repetitions and junk - (ptr acceptable (cdr ptr)) ;pointer in acceptable - (this (car ptr) (car ptr)) ;current acceptable keyword - (auxval nil) ;used to move values around - (alist '())) ;used to build the result - ((endp ptr) alist) - ;; if THIS appears in auxlist, use its value - (when (setq auxval (assq this auxlist)) - (setq alist (cons auxval alist)))))) - - -(defun extract-from-klist (klist key &optional default) - "(extract-from-klist KLIST KEY [DEFAULT]) => value of KEY or DEFAULT -Extract value associated with KEY in KLIST (return DEFAULT if nil)." - (let ((retrieved (cdr (assq key klist)))) - (or retrieved default))) - -(defun keyword-argument-supplied-p (klist key) - "(keyword-argument-supplied-p KLIST KEY) => nil or something -NIL if KEY (a keyword) does not appear in the KLIST." - (assq key klist)) - -(defun add-to-klist (key item klist) - "(ADD-TO-KLIST KEY ITEM KLIST) => new KLIST -Add association (KEY . ITEM) to KLIST." - (setq klist (acons key item klist))) - -(defun elt-satisfies-test-p (item elt klist) - "(elt-satisfies-test-p ITEM ELT KLIST) => t or nil -KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. -True if the given ITEM and ELT satisfy the test." - (let ((test (extract-from-klist klist :test)) - (test-not (extract-from-klist klist :test-not)) - (keyfn (extract-from-klist klist :key 'identity))) - (cond (test - (funcall test item (funcall keyfn elt))) - (test-not - (not (funcall test-not item (funcall keyfn elt)))) - (t ;should never happen - (error "neither :test nor :test-not in `%s'" - (prin1-to-string klist)))))) - -(defun elt-satisfies-if-p (item klist) - "(elt-satisfies-if-p ITEM KLIST) => t or nil -True if an -if style function was called and ITEM satisfies the -predicate under :predicate in KLIST." - (let ((predicate (extract-from-klist klist :predicate)) - (keyfn (extract-from-klist klist :key 'identity))) - (funcall predicate (funcall keyfn item)))) - -(defun elt-satisfies-if-not-p (item klist) - "(elt-satisfies-if-not-p ITEM KLIST) => t or nil -KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. -True if an -if-not style function was called and ITEM does not satisfy -the predicate under :predicate in KLIST." - (let ((predicate (extract-from-klist klist :predicate)) - (keyfn (extract-from-klist klist :key 'identity))) - (not (funcall predicate (funcall keyfn item))))) - -(defun elts-match-under-klist-p (e1 e2 klist) - "(elts-match-under-klist-p E1 E2 KLIST) => t or nil -KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. -True if elements E1 and E2 match under the tests encoded in KLIST." - (let ((test (extract-from-klist klist :test)) - (test-not (extract-from-klist klist :test-not)) - (keyfn (extract-from-klist klist :key 'identity))) - (if (and test test-not) - (error "both :test and :test-not in `%s'" - (prin1-to-string klist))) - (cond (test - (funcall test (funcall keyfn e1) (funcall keyfn e2))) - (test-not - (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2)))) - (t ;should never happen - (error "neither :test nor :test-not in `%s'" - (prin1-to-string klist)))))) - -;;; This macro simplifies using keyword args. It is less clumsy than using -;;; the primitives build-klist, etc... For instance, member could be written -;;; this way: - -;;; (defun member (item list &rest kargs) -;;; (with-keyword-args kargs (test test-not (key 'identity)) -;;; ...)) - -;;; Suggested by Robert Potter (potter@cs.rochester.edu, 15 Nov 1989) - -(defmacro with-keyword-args (keyargslist vardefs &rest body) - "(WITH-KEYWORD-ARGS KEYARGSLIST VARDEFS . BODY) -KEYARGSLIST can be either a symbol or a list of one or two symbols. -In the second case, the second symbol is either T or NIL, indicating whether -keywords other than the mentioned ones are tolerable. - -VARDEFS is a list. Each entry is either a VAR (symbol) or matches -\(VAR [DEFAULT [KEYWORD]]). Just giving VAR is the same as giving -\(VAR nil :VAR). - -The BODY is executed in an environment where each VAR (a symbol) is bound to -the value present in the KEYARGSLIST provided, or to the DEFAULT. The value -is searched by using the keyword form of VAR (i.e., :VAR) or the optional -keyword if provided. - -Notice that this macro doesn't distinguish between a default value given -explicitly by the user and one provided by default. See also the more -primitive functions build-klist, add-to-klist, extract-from-klist, -keyword-argument-supplied-p, elt-satisfies-test-p, elt-satisfies-if-p, -elt-satisfies-if-not-p, elts-match-under-klist-p. They provide more complete, -if clumsier, control over this feature." - (let (allow-other-keys) - (if (listp keyargslist) - (if (> (length keyargslist) 2) - (error - "`%s' should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)" - (prin1-to-string keyargslist)) - (setq allow-other-keys (cadr keyargslist) - keyargslist (car keyargslist)) - (if (not (and - (symbolp keyargslist) - (memq allow-other-keys '(t nil)))) - (error - "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)" - ))) - (if (symbolp keyargslist) - (setq allow-other-keys nil) - (error - "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)"))) - (let (vars defaults keywords forms - (klistname (gensym "KLIST_"))) - (mapcar (function (lambda (entry) - (if (symbolp entry) ;defaulty case - (setq entry (list entry nil (keyword-of entry)))) - (let* ((l (length entry)) - (v (car entry)) - (d (cadr entry)) - (k (caddr entry))) - (if (or (< l 1) (> l 3)) - (error - "`%s' must match (VAR [DEFAULT [KEYWORD]])" - (prin1-to-string entry))) - (if (or (null v) (not (symbolp v))) - (error - "bad variable `%s': must be non-null symbol" - (prin1-to-string v))) - (setq vars (cons v vars)) - (setq defaults (cons d defaults)) - (if (< l 3) - (setq k (keyword-of v))) - (if (and (= l 3) - (or (null k) - (not (keywordp k)))) - (error - "bad keyword `%s'" (prin1-to-string k))) - (setq keywords (cons k keywords)) - (setq forms (cons (list v (list 'extract-from-klist - klistname - k - d)) - forms))))) - vardefs) - (append - (list 'let* (nconc (list (list klistname - (list 'build-klist keyargslist - (list 'quote keywords) - allow-other-keys))) - (nreverse forms))) - body)))) -(put 'with-keyword-args 'lisp-indent-hook 1) - - -;;; REDUCE -;;; It is here mostly as an example of how to use KLISTs. -;;; -;;; First of all, you need to declare the keywords (done elsewhere in this -;;; file): -;;; (defkeyword :from-end "syntax of sequence functions") -;;; (defkeyword :start "syntax of sequence functions") -;;; etc... -;;; -;;; Then, you capture all the possible keyword arguments with a &rest -;;; argument. You can pass that list downward again, of course, but -;;; internally you need to parse it into a KLIST (an alist, really). One uses -;;; (build-klist REST-ARGS ACCEPTABLE-KEYWORDS [ALLOW-OTHER]). You can then -;;; test for presence by using (keyword-argument-supplied-p KLIST KEY) and -;;; extract a value with (extract-from-klist KLIST KEY [DEFAULT]). - -(defun reduce (function sequence &rest kargs) - "Apply FUNCTION (a function of two arguments) to successive pairs of elements -from SEQUENCE. Some keyword arguments are valid after FUNCTION and SEQUENCE: -:from-end If non-nil, process the values backwards -:initial-value If given, prefix it to the SEQUENCE. Suffix, if :from-end -:start Restrict reduction to the subsequence from this index -:end Restrict reduction to the subsequence BEFORE this index. -If the sequence is empty and no :initial-value is given, the FUNCTION is -called on zero (not two) arguments. Otherwise, if there is exactly one -element in the combination of SEQUENCE and the initial value, that element is -returned." - (let* ((klist (build-klist kargs '(:from-end :start :end :initial-value))) - (length (length sequence)) - (from-end (extract-from-klist klist :from-end)) - (initial-value-given (keyword-argument-supplied-p - klist :initial-value)) - (start (extract-from-klist kargs :start 0)) - (end (extract-from-klist kargs :end length))) - (setq sequence (cl$subseq-as-list sequence start end)) - (if from-end - (setq sequence (reverse sequence))) - (if initial-value-given - (setq sequence (cons (extract-from-klist klist :initial-value) - sequence))) - (if (null sequence) - (funcall function) ;only use of 0 arguments - (let* ((result (car sequence)) - (sequence (cdr sequence))) - (while sequence - (setq result (if from-end - (funcall function (car sequence) result) - (funcall function result (car sequence))) - sequence (cdr sequence))) - result)))) - -(defun cl$subseq-as-list (sequence start end) - "(cl$subseq-as-list SEQUENCE START END) => a list" - (let ((list (append sequence nil)) - (length (length sequence)) - result) - (if (< start 0) - (error "start should be >= 0, not %d" start)) - (if (> end length) - (error "end should be <= %d, not %d" length end)) - (if (and (zerop start) (= end length)) - list - (let ((i start) - (vector (apply 'vector list))) - (while (/= i end) - (setq result (cons (elt vector i) result)) - (setq i (+ i 1))) - (nreverse result))))) - -;;;; end of cl-sequences.el - -;;;; Some functions with keyword arguments -;;;; -;;;; Both list and sequence functions are considered here together. This -;;;; doesn't fit any more with the original split of functions in files. - -(defun cl-member (item list &rest kargs) - "Look for ITEM in LIST; return first tail of LIST the car of whose first -cons cell tests the same as ITEM. Admits arguments :key, :test, and -:test-not." - (if (null kargs) ;treat this fast for efficiency - (memq item list) - (let* ((klist (build-klist kargs '(:test :test-not :key))) - (test (extract-from-klist klist :test)) - (testnot (extract-from-klist klist :test-not)) - (key (extract-from-klist klist :key 'identity))) - ;; another workaround allegedly for speed, BLAH - (if (and (or (eq test 'eq) (eq test 'eql) - (eq test (symbol-function 'eq)) - (eq test (symbol-function 'eql))) - (null testnot) - (or (eq key 'identity) ;either by default or so given - (eq key (function identity)) ;could this happen? - (eq key (symbol-function 'identity)) ;sheer paranoia - )) - (memq item list) - (if (and test testnot) - (error ":test and :test-not both specified for member")) - (if (not (or test testnot)) - (setq test 'eql)) - ;; final hack: remove the indirection through the function names - (if testnot - (if (symbolp testnot) - (setq testnot (symbol-function testnot))) - (if (symbolp test) - (setq test (symbol-function test)))) - (if (symbolp key) - (setq key (symbol-function key))) - ;; ok, go for it - (let ((ptr list) - (done nil) - (result '())) - (if testnot - (while (not (or done (endp ptr))) - (cond ((not (funcall testnot item (funcall key (car ptr)))) - (setq done t) - (setq result ptr))) - (setq ptr (cdr ptr))) - (while (not (or done (endp ptr))) - (cond ((funcall test item (funcall key (car ptr))) - (setq done t) - (setq result ptr))) - (setq ptr (cdr ptr)))) - result))))) - -;;;; MULTIPLE VALUES -;;;; This package approximates the behavior of the multiple-values -;;;; forms of Common Lisp. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - -;;; Lisp indentation information -(put 'multiple-value-bind 'lisp-indent-hook 2) -(put 'multiple-value-setq 'lisp-indent-hook 2) -(put 'multiple-value-list 'lisp-indent-hook nil) -(put 'multiple-value-call 'lisp-indent-hook 1) -(put 'multiple-value-prog1 'lisp-indent-hook 1) - -;;; Global state of the package is kept here -(defvar *mvalues-values* nil - "Most recently returned multiple-values") -(defvar *mvalues-count* nil - "Count of multiple-values returned, or nil if the mechanism was not used") - -;;; values is the standard multiple-value-return form. Must be the -;;; last thing evaluated inside a function. If the caller is not -;;; expecting multiple values, only the first one is passed. (values) -;;; is the same as no-values returned (unaware callers see nil). The -;;; alternative (values-list <list>) is just a convenient shorthand -;;; and complements multiple-value-list. - -(defun values (&rest val-forms) - "Produce multiple values (zero or more). Each arg is one value. -See also `multiple-value-bind', which is one way to examine the -multiple values produced by a form. If the containing form or caller -does not check specially to see multiple values, it will see only -the first value." - (setq *mvalues-values* val-forms) - (setq *mvalues-count* (length *mvalues-values*)) - (car *mvalues-values*)) - -(defun values-list (&optional val-forms) - "Produce multiple values (zero or more). Each element of LIST is one value. -This is equivalent to (apply 'values LIST)." - (cond ((nlistp val-forms) - (error "Argument to values-list must be a list, not `%s'" - (prin1-to-string val-forms)))) - (setq *mvalues-values* val-forms) - (setq *mvalues-count* (length *mvalues-values*)) - (car *mvalues-values*)) - -;;; Callers that want to see the multiple values use these macros. - -(defmacro multiple-value-list (form) - "Execute FORM and return a list of all the (multiple) values FORM produces. -See `values' and `multiple-value-bind'." - (list 'progn - (list 'setq '*mvalues-count* nil) - (list 'let (list (list 'it '(gensym))) - (list 'set 'it form) - (list 'if '*mvalues-count* - (list 'copy-sequence '*mvalues-values*) - (list 'progn - (list 'setq '*mvalues-count* 1) - (list 'setq '*mvalues-values* - (list 'list (list 'symbol-value 'it))) - (list 'copy-sequence '*mvalues-values*)))))) - -(defmacro multiple-value-call (function &rest args) - "Call FUNCTION on all the values produced by the remaining arguments. -(multiple-value-call '+ (values 1 2) (values 3 4)) is 10." - (let* ((result (gentemp)) - (arg (gentemp))) - (list 'apply (list 'function (eval function)) - (list 'let* (list (list result '())) - (list 'dolist (list arg (list 'quote args) result) - (list 'setq result - (list 'append - result - (list 'multiple-value-list - (list 'eval arg))))))))) - -(defmacro multiple-value-bind (vars form &rest body) - "Bind VARS to the (multiple) values produced by FORM, then do BODY. -VARS is a list of variables; each is bound to one of FORM's values. -If FORM doesn't make enough values, the extra variables are bound to nil. -(Ordinary forms produce only one value; to produce more, use `values'.) -Extra values are ignored. -BODY (zero or more forms) is executed with the variables bound, -then the bindings are unwound." - (let* ((vals (gentemp)) ;name for intermediate values - (clauses (mv-bind-clausify ;convert into clauses usable - vars vals))) ; in a let form - (list* 'let* - (cons (list vals (list 'multiple-value-list form)) - clauses) - body))) - -(defmacro multiple-value-setq (vars form) - "Set VARS to the (multiple) values produced by FORM. -VARS is a list of variables; each is set to one of FORM's values. -If FORM doesn't make enough values, the extra variables are set to nil. -(Ordinary forms produce only one value; to produce more, use `values'.) -Extra values are ignored." - (let* ((vals (gentemp)) ;name for intermediate values - (clauses (mv-bind-clausify ;convert into clauses usable - vars vals))) ; in a setq (after append). - (list 'let* - (list (list vals (list 'multiple-value-list form))) - (cons 'setq (apply (function append) clauses))))) - -(defmacro multiple-value-prog1 (form &rest body) - "Evaluate FORM, then BODY, then produce the same values FORM produced. -Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2. -This is like `prog1' except that `prog1' would produce only one value, -which would be the first of FORM's values." - (let* ((heldvalues (gentemp))) - (cons 'let* - (cons (list (list heldvalues (list 'multiple-value-list form))) - (append body (list (list 'values-list heldvalues))))))) - -;;; utility functions -;;; -;;; mv-bind-clausify makes the pairs needed to have the variables in -;;; the variable list correspond with the values returned by the form. -;;; vals is a fresh symbol that intervenes in all the bindings. - -(defun mv-bind-clausify (vars vals) - "MV-BIND-CLAUSIFY VARS VALS => Auxiliary list -Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to -the length of VARS (a list of symbols). VALS is just a fresh symbol." - (if (or (nlistp vars) - (notevery 'symbolp vars)) - (error "expected a list of symbols, not `%s'" - (prin1-to-string vars))) - (let* ((nvars (length vars)) - (clauses '())) - (dotimes (n nvars clauses) - (setq clauses (cons (list (nth n vars) - (list 'nth n vals)) clauses))))) - -;;;; end of cl-multiple-values.el - -;;;; ARITH -;;;; This file provides integer arithmetic extensions. Although -;;;; Emacs Lisp doesn't really support anything but integers, that -;;;; has still to be made to look more or less standard. -;;;; -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - - -(defsubst plusp (number) - "True if NUMBER is strictly greater than zero." - (> number 0)) - -(defsubst minusp (number) - "True if NUMBER is strictly less than zero." - (< number 0)) - -(defsubst oddp (number) - "True if INTEGER is not divisible by 2." - (/= (% number 2) 0)) - -(defsubst evenp (number) - "True if INTEGER is divisible by 2." - (= (% number 2) 0)) - -(defsubst abs (number) - "Return the absolute value of NUMBER." - (if (< number 0) - (- number) - number)) - -(defsubst signum (number) - "Return -1, 0 or 1 according to the sign of NUMBER." - (cond ((< number 0) - -1) - ((> number 0) - 1) - (t ;exactly zero - 0))) - -(defun gcd (&rest integers) - "Return the greatest common divisor of all the arguments. -The arguments must be integers. With no arguments, value is zero." - (let ((howmany (length integers))) - (cond ((= howmany 0) - 0) - ((= howmany 1) - (abs (car integers))) - ((> howmany 2) - (apply (function gcd) - (cons (gcd (nth 0 integers) (nth 1 integers)) - (nthcdr 2 integers)))) - (t ;howmany=2 - ;; essentially the euclidean algorithm - (when (zerop (* (nth 0 integers) (nth 1 integers))) - (error "a zero argument is invalid for `gcd'")) - (do* ((absa (abs (nth 0 integers))) ; better to operate only - (absb (abs (nth 1 integers))) ;on positives. - (dd (max absa absb)) ; setup correct order for the - (ds (min absa absb)) ;successive divisions. - ;; intermediate results - (q 0) - (r 0) - ;; final results - (done nil) ; flag: end of iterations - (result 0)) ; final value - (done result) - (setq q (/ dd ds)) - (setq r (% dd ds)) - (cond ((zerop r) (setq done t) (setq result ds)) - (t (setq dd ds) (setq ds r)))))))) - -(defun lcm (integer &rest more) - "Return the least common multiple of all the arguments. -The arguments must be integers and there must be at least one of them." - (let ((howmany (length more)) - (a integer) - (b (nth 0 more)) - prod ; intermediate product - (yetmore (nthcdr 1 more))) - (cond ((zerop howmany) - (abs a)) - ((> howmany 1) ; recursive case - (apply (function lcm) - (cons (lcm a b) yetmore))) - (t ; base case, just 2 args - (setq prod (* a b)) - (cond - ((zerop prod) - 0) - (t - (/ (abs prod) (gcd a b)))))))) - -(defun isqrt (number) - "Return the integer square root of NUMBER. -NUMBER must not be negative. Result is largest integer less than or -equal to the real square root of the argument." - ;; The method used here is essentially the Newtonian iteration - ;; x[n+1] <- (x[n] + Number/x[n]) / 2 - ;; suitably adapted to integer arithmetic. - ;; Thanks to Philippe Schnoebelen <phs@lifia.imag.fr> for suggesting the - ;; termination condition. - (cond ((minusp number) - (error "argument to `isqrt' (%d) must not be negative" - number)) - ((zerop number) - 0) - (t ;so (>= number 0) - (do* ((approx 1) ;any positive integer will do - (new 0) ;init value irrelevant - (done nil)) - (done (if (> (* approx approx) number) - (- approx 1) - approx)) - (setq new (/ (+ approx (/ number approx)) 2) - done (or (= new approx) (= new (+ approx 1))) - approx new))))) - -(defun cl-floor (number &optional divisor) - "Divide DIVIDEND by DIVISOR, rounding toward minus infinity. -DIVISOR defaults to 1. The remainder is produced as a second value." - (cond ((and (null divisor) ; trivial case - (numberp number)) - (values number 0)) - (t ; do the division - (multiple-value-bind - (q r s) - (safe-idiv number divisor) - (cond ((zerop s) - (values 0 0)) - ((plusp s) - (values q r)) - (t ;opposite-signs case - (if (zerop r) - (values (- q) 0) - (let ((q (- (+ q 1)))) - (values q (- number (* q divisor))))))))))) - -(defun cl-ceiling (number &optional divisor) - "Divide DIVIDEND by DIVISOR, rounding toward plus infinity. -DIVISOR defaults to 1. The remainder is produced as a second value." - (cond ((and (null divisor) ; trivial case - (numberp number)) - (values number 0)) - (t ; do the division - (multiple-value-bind - (q r s) - (safe-idiv number divisor) - (cond ((zerop s) - (values 0 0)) - ((plusp s) - (values (+ q 1) (- r divisor))) - (t - (values (- q) (+ number (* q divisor))))))))) - -(defun cl-truncate (number &optional divisor) - "Divide DIVIDEND by DIVISOR, rounding toward zero. -DIVISOR defaults to 1. The remainder is produced as a second value." - (cond ((and (null divisor) ; trivial case - (numberp number)) - (values number 0)) - (t ; do the division - (multiple-value-bind - (q r s) - (safe-idiv number divisor) - (cond ((zerop s) - (values 0 0)) - ((plusp s) ;same as floor - (values q r)) - (t ;same as ceiling - (values (- q) (+ number (* q divisor))))))))) - -(defun cl-round (number &optional divisor) - "Divide DIVIDEND by DIVISOR, rounding to nearest integer. -DIVISOR defaults to 1. The remainder is produced as a second value." - (cond ((and (null divisor) ; trivial case - (numberp number)) - (values number 0)) - (t ; do the division - (multiple-value-bind - (q r s) - (safe-idiv number divisor) - (setq r (abs r)) - ;; adjust magnitudes first, and then signs - (let ((other-r (- (abs divisor) r))) - (cond ((> r other-r) - (setq q (+ q 1))) - ((and (= r other-r) - (oddp q)) - ;; round to even is mandatory - (setq q (+ q 1)))) - (setq q (* s q)) - (setq r (- number (* q divisor))) - (values q r)))))) - -;;; These two functions access the implementation-dependent representation of -;;; the multiple value returns. - -(defun cl-mod (number divisor) - "Return remainder of X by Y (rounding quotient toward minus infinity). -That is, the remainder goes with the quotient produced by `cl-floor'. -Emacs Lisp hint: -If you know that both arguments are positive, use `%' instead for speed." - (cl-floor number divisor) - (cadr *mvalues-values*)) - -(defun rem (number divisor) - "Return remainder of X by Y (rounding quotient toward zero). -That is, the remainder goes with the quotient produced by `cl-truncate'. -Emacs Lisp hint: -If you know that both arguments are positive, use `%' instead for speed." - (cl-truncate number divisor) - (cadr *mvalues-values*)) - -;;; internal utilities -;;; -;;; safe-idiv performs an integer division with positive numbers only. -;;; It is known that some machines/compilers implement weird remainder -;;; computations when working with negatives, so the idea here is to -;;; make sure we know what is coming back to the caller in all cases. - -;;; Signum computation fixed by mad@math.keio.JUNET (MAEDA Atusi) - -(defun safe-idiv (a b) - "SAFE-IDIV A B => Q R S -Q=|A|/|B|, S is the sign of A/B, R is the rest A - S*Q*B." - ;; (unless (and (numberp a) (numberp b)) - ;; (error "arguments to `safe-idiv' must be numbers")) - ;; (when (zerop b) - ;; (error "cannot divide %d by zero" a)) - (let* ((q (/ (abs a) (abs b))) - (s (* (signum a) (signum b))) - (r (- a (* s q b)))) - (values q r s))) - -;;;; end of cl-arith.el - -;;;; SETF -;;;; This file provides the setf macro and friends. The purpose has -;;;; been modest, only the simplest defsetf forms are accepted. -;;;; Use it and enjoy. -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - - -(defkeyword :setf-update-fn - "Property, its value is the function setf must invoke to update a -generalized variable whose access form is a function call of the -symbol that has this property.") - -(defkeyword :setf-update-doc - "Property of symbols that have a `defsetf' update function on them, -installed by the `defsetf' from its optional third argument.") - -(defmacro setf (&rest pairs) - "Generalized `setq' that can set things other than variable values. -A use of `setf' looks like (setf {PLACE VALUE}...). -The behavior of (setf PLACE VALUE) is to access the generalized variable -at PLACE and store VALUE there. It returns VALUE. If there is more -than one PLACE and VALUE, each PLACE is set from its VALUE before -the next PLACE is evaluated." - (let ((nforms (length pairs))) - ;; check the number of subforms - (cond ((/= (% nforms 2) 0) - (error "odd number of arguments to `setf'")) - ((= nforms 0) - nil) - ((> nforms 2) - ;; this is the recursive case - (cons 'progn - (do* ;collect the place-value pairs - ((args pairs (cddr args)) - (place (car args) (car args)) - (value (cadr args) (cadr args)) - (result '())) - ((endp args) (nreverse result)) - (setq result - (cons (list 'setf place value) - result))))) - (t ;i.e., nforms=2 - ;; this is the base case (SETF PLACE VALUE) - (let* ((place (car pairs)) - (value (cadr pairs)) - (head nil) - (updatefn nil)) - ;; dispatch on the type of the PLACE - (cond ((symbolp place) - (list 'setq place value)) - ((and (listp place) - (setq head (car place)) - (symbolp head) - (setq updatefn (get head :setf-update-fn))) - ;; dispatch on the type of update function - (cond ((and (consp updatefn) (eq (car updatefn) 'lambda)) - (cons 'funcall - (cons (list 'function updatefn) - (append (cdr place) (list value))))) - ((and (symbolp updatefn) - (fboundp updatefn) - (let ((defn (symbol-function updatefn))) - (or (subrp defn) - (and (consp defn) - (or (eq (car defn) 'lambda) - (eq (car defn) 'macro)))))) - (cons updatefn (append (cdr place) (list value)))) - (t - (multiple-value-bind - (bindings newsyms) - (pair-with-newsyms - (append (cdr place) (list value))) - ;; this let gets new symbols to ensure adequate - ;; order of evaluation of the subforms. - (list 'let - bindings - (cons updatefn newsyms)))))) - (t - (error "no `setf' update-function for `%s'" - (prin1-to-string place))))))))) - -(defmacro defsetf (accessfn updatefn &optional docstring) - "Define how `setf' works on a certain kind of generalized variable. -A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]). -ACCESSFN is a symbol. UPDATEFN is a function or macro which takes -one more argument than ACCESSFN does. DEFSETF defines the translation -of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL). -The function UPDATEFN must return its last arg, after performing the -updating called for." - ;; reject ill-formed requests. too bad one can't test for functionp - ;; or macrop. - (when (not (symbolp accessfn)) - (error "first argument of `defsetf' must be a symbol, not `%s'" - (prin1-to-string accessfn))) - ;; update properties - (list 'progn - (list 'eval-and-compile - (list 'put (list 'quote accessfn) - :setf-update-fn (list 'function updatefn))) - (list 'put (list 'quote accessfn) :setf-update-doc docstring) - ;; any better thing to return? - (list 'quote accessfn))) - -;;; This section provides the "default" setfs for Common-Emacs-Lisp -;;; The user will not normally add anything to this, although -;;; defstruct will introduce new ones as a matter of fact. -;;; -;;; Apply is a special case. The Common Lisp -;;; standard makes the case of apply be useful when the user writes -;;; something like (apply #'name ...), Emacs Lisp doesn't have the # -;;; stuff, but it has (function ...). Notice that V18 includes a new -;;; apply: this file is compatible with V18 and pre-V18 Emacses. - -;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the -;;; (correct) left to right sequence *before* checking for apply -;;; methods (which should really be an special case inside setf). Due -;;; to this, the lambda expression defsetf'd to apply will succeed in -;;; applying the right function even if the name was not quoted, but -;;; computed! That extension is not Common Lisp (nor is particularly -;;; useful, I think). - -(defsetf apply - (lambda (&rest args) - ;; disassemble the calling form - ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too) - (let* ((fnform (car args)) ;functional form - (applyargs (append ;arguments "to apply fnform" - (apply 'list* (butlast (cdr args))) - (last args))) - (newupdater nil)) ; its update-fn, if any - (if (and (symbolp fnform) - (setq newupdater (get fnform :setf-update-fn))) - (apply newupdater applyargs) - (error "can't `setf' to `%s'" - (prin1-to-string fnform))))) - "`apply' is a special case for `setf'") - - -(defsetf aref - aset - "`setf' inversion for `aref'") - -(defsetf nth - setnth - "`setf' inversion for `nth'") - -(defsetf nthcdr - setnthcdr - "`setf' inversion for `nthcdr'") - -(defsetf elt - setelt - "`setf' inversion for `elt'") - -(defsetf first - (lambda (list val) (setnth 0 list val)) - "`setf' inversion for `first'") - -(defsetf second - (lambda (list val) (setnth 1 list val)) - "`setf' inversion for `second'") - -(defsetf third - (lambda (list val) (setnth 2 list val)) - "`setf' inversion for `third'") - -(defsetf fourth - (lambda (list val) (setnth 3 list val)) - "`setf' inversion for `fourth'") - -(defsetf fifth - (lambda (list val) (setnth 4 list val)) - "`setf' inversion for `fifth'") - -(defsetf sixth - (lambda (list val) (setnth 5 list val)) - "`setf' inversion for `sixth'") - -(defsetf seventh - (lambda (list val) (setnth 6 list val)) - "`setf' inversion for `seventh'") - -(defsetf eighth - (lambda (list val) (setnth 7 list val)) - "`setf' inversion for `eighth'") - -(defsetf ninth - (lambda (list val) (setnth 8 list val)) - "`setf' inversion for `ninth'") - -(defsetf tenth - (lambda (list val) (setnth 9 list val)) - "`setf' inversion for `tenth'") - -(defsetf rest - (lambda (list val) (setcdr list val)) - "`setf' inversion for `rest'") - -(defsetf car setcar "Replace the car of a cons") - -(defsetf cdr setcdr "Replace the cdr of a cons") - -(defsetf caar - (lambda (list val) (setcar (nth 0 list) val)) - "`setf' inversion for `caar'") - -(defsetf cadr - (lambda (list val) (setcar (cdr list) val)) - "`setf' inversion for `cadr'") - -(defsetf cdar - (lambda (list val) (setcdr (car list) val)) - "`setf' inversion for `cdar'") - -(defsetf cddr - (lambda (list val) (setcdr (cdr list) val)) - "`setf' inversion for `cddr'") - -(defsetf caaar - (lambda (list val) (setcar (caar list) val)) - "`setf' inversion for `caaar'") - -(defsetf caadr - (lambda (list val) (setcar (cadr list) val)) - "`setf' inversion for `caadr'") - -(defsetf cadar - (lambda (list val) (setcar (cdar list) val)) - "`setf' inversion for `cadar'") - -(defsetf cdaar - (lambda (list val) (setcdr (caar list) val)) - "`setf' inversion for `cdaar'") - -(defsetf caddr - (lambda (list val) (setcar (cddr list) val)) - "`setf' inversion for `caddr'") - -(defsetf cdadr - (lambda (list val) (setcdr (cadr list) val)) - "`setf' inversion for `cdadr'") - -(defsetf cddar - (lambda (list val) (setcdr (cdar list) val)) - "`setf' inversion for `cddar'") - -(defsetf cdddr - (lambda (list val) (setcdr (cddr list) val)) - "`setf' inversion for `cdddr'") - -(defsetf caaaar - (lambda (list val) (setcar (caaar list) val)) - "`setf' inversion for `caaaar'") - -(defsetf caaadr - (lambda (list val) (setcar (caadr list) val)) - "`setf' inversion for `caaadr'") - -(defsetf caadar - (lambda (list val) (setcar (cadar list) val)) - "`setf' inversion for `caadar'") - -(defsetf cadaar - (lambda (list val) (setcar (cdaar list) val)) - "`setf' inversion for `cadaar'") - -(defsetf cdaaar - (lambda (list val) (setcdr (caar list) val)) - "`setf' inversion for `cdaaar'") - -(defsetf caaddr - (lambda (list val) (setcar (caddr list) val)) - "`setf' inversion for `caaddr'") - -(defsetf cadadr - (lambda (list val) (setcar (cdadr list) val)) - "`setf' inversion for `cadadr'") - -(defsetf cdaadr - (lambda (list val) (setcdr (caadr list) val)) - "`setf' inversion for `cdaadr'") - -(defsetf caddar - (lambda (list val) (setcar (cddar list) val)) - "`setf' inversion for `caddar'") - -(defsetf cdadar - (lambda (list val) (setcdr (cadar list) val)) - "`setf' inversion for `cdadar'") - -(defsetf cddaar - (lambda (list val) (setcdr (cdaar list) val)) - "`setf' inversion for `cddaar'") - -(defsetf cadddr - (lambda (list val) (setcar (cdddr list) val)) - "`setf' inversion for `cadddr'") - -(defsetf cddadr - (lambda (list val) (setcdr (cdadr list) val)) - "`setf' inversion for `cddadr'") - -(defsetf cdaddr - (lambda (list val) (setcdr (caddr list) val)) - "`setf' inversion for `cdaddr'") - -(defsetf cdddar - (lambda (list val) (setcdr (cddar list) val)) - "`setf' inversion for `cdddar'") - -(defsetf cddddr - (lambda (list val) (setcdr (cddr list) val)) - "`setf' inversion for `cddddr'") - -(defsetf get put "`setf' inversion for `get' is `put'") - -(defsetf symbol-function fset - "`setf' inversion for `symbol-function' is `fset'") - -(defsetf symbol-plist setplist - "`setf' inversion for `symbol-plist' is `setplist'") - -(defsetf symbol-value set - "`setf' inversion for `symbol-value' is `set'") - -(defsetf point goto-char - "To set (point) to N, use (goto-char N)") - -;; how about defsetfing other Emacs forms? - -;;; Modify macros -;;; -;;; It could be nice to implement define-modify-macro, but I don't -;;; think it really pays. - -(defmacro incf (ref &optional delta) - "(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)" - (if (null delta) - (setq delta 1)) - (list 'setf ref (list '+ ref delta))) - -(defmacro decf (ref &optional delta) - "(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)" - (if (null delta) - (setq delta 1)) - (list 'setf ref (list '- ref delta))) - -(defmacro push (item ref) - "(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)" - (list 'setf ref (list 'cons item ref))) - -(defmacro pushnew (item ref) - "(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)" - (list 'setf ref (list 'adjoin item ref))) - -(defmacro pop (ref) - "(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))" - (let ((listname (gensym))) - (list 'let (list (list listname ref)) - (list 'prog1 - (list 'car listname) - (list 'setf ref (list 'cdr listname)))))) - -;;; PSETF -;;; -;;; Psetf is the generalized variable equivalent of psetq. The right -;;; hand sides are evaluated and assigned (via setf) to the left hand -;;; sides. The evaluations are done in an environment where they -;;; appear to occur in parallel. - -(defmacro psetf (&rest body) - "(psetf {var value }...) => nil -Like setf, but all the values are computed before any assignment is made." - (let ((length (length body))) - (cond ((/= (% length 2) 0) - (error "psetf needs an even number of arguments, %d given" - length)) - ((null body) - '()) - (t - (list 'prog1 nil - (let ((setfs '()) - (bodyforms (reverse body))) - (while bodyforms - (let* ((value (car bodyforms)) - (place (cadr bodyforms))) - (setq bodyforms (cddr bodyforms)) - (if (null setfs) - (setq setfs (list 'setf place value)) - (setq setfs (list 'setf place - (list 'prog1 value - setfs)))))) - setfs)))))) - -;;; SHIFTF and ROTATEF -;;; - -(defmacro shiftf (&rest forms) - "(shiftf PLACE1 PLACE2... NEWVALUE) -Set PLACE1 to PLACE2, PLACE2 to PLACE3... -Each PLACE is set to the old value of the following PLACE, -and the last PLACE is set to the value NEWVALUE. -Returns the old value of PLACE1." - (unless (> (length forms) 1) - (error "`shiftf' needs more than one argument")) - (let ((places (butlast forms)) - (newvalue (car (last forms)))) - ;; the places are accessed to fresh symbols - (multiple-value-bind - (bindings newsyms) - (pair-with-newsyms places) - (list 'let bindings - (cons 'setf - (zip-lists places - (append (cdr newsyms) (list newvalue)))) - (car newsyms))))) - -(defmacro rotatef (&rest places) - "(rotatef PLACE...) sets each PLACE to the old value of the following PLACE. -The last PLACE is set to the old value of the first PLACE. -Thus, the values rotate through the PLACEs. Returns nil." - (if (null places) - nil - (multiple-value-bind - (bindings newsyms) - (pair-with-newsyms places) - (list - 'let bindings - (cons 'setf - (zip-lists places - (append (cdr newsyms) (list (car newsyms))))) - nil)))) - -;;; GETF, REMF, and REMPROP -;;; - -(defun getf (place indicator &optional default) - "Return PLACE's PROPNAME property, or DEFAULT if not present." - (while (and place (not (eq (car place) indicator))) - (setq place (cdr (cdr place)))) - (if place - (car (cdr place)) - default)) - -(defmacro getf$setf$method (place indicator default &rest newval) - "SETF method for GETF. Not for public use." - (case (length newval) - (0 (setq newval default default nil)) - (1 (setq newval (car newval))) - (t (error "Wrong number of arguments to (setf (getf ...)) form"))) - (let ((psym (gentemp)) (isym (gentemp)) (vsym (gentemp))) - (list 'let (list (list psym place) - (list isym indicator) - (list vsym newval)) - (list 'while - (list 'and psym - (list 'not - (list 'eq (list 'car psym) isym))) - (list 'setq psym (list 'cdr (list 'cdr psym)))) - (list 'if psym - (list 'setcar (list 'cdr psym) vsym) - (list 'setf place - (list 'nconc place (list 'list isym newval)))) - vsym))) - -(defsetf getf - getf$setf$method) - -(defmacro remf (place indicator) - "Remove from the property list at PLACE its PROPNAME property. -Returns non-nil if and only if the property existed." - (let ((psym (gentemp)) (isym (gentemp))) - (list 'let (list (list psym place) (list isym indicator)) - (list 'cond - (list (list 'eq isym (list 'car psym)) - (list 'setf place (list 'cdr (list 'cdr psym))) - t) - (list t - (list 'setq psym (list 'cdr psym)) - (list 'while - (list 'and (list 'cdr psym) - (list 'not - (list 'eq (list 'car (list 'cdr psym)) - isym))) - (list 'setq psym (list 'cdr (list 'cdr psym)))) - (list 'cond - (list (list 'cdr psym) - (list 'setcdr psym - (list 'cdr - (list 'cdr (list 'cdr psym)))) - t))))))) - -(defun remprop (symbol indicator) - "Remove SYMBOL's PROPNAME property, returning non-nil if it was present." - (remf (symbol-plist symbol) indicator)) - - -;;;; STRUCTS -;;;; This file provides the structures mechanism. See the -;;;; documentation for Common-Lisp's defstruct. Mine doesn't -;;;; implement all the functionality of the standard, although some -;;;; more could be grafted if so desired. More details along with -;;;; the code. -;;;; -;;;; -;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 -;;;; (quiroz@cs.rochester.edu) - - -(defkeyword :include "Syntax of `defstruct'") -(defkeyword :named "Syntax of `defstruct'") -(defkeyword :conc-name "Syntax of `defstruct'") -(defkeyword :copier "Syntax of `defstruct'") -(defkeyword :predicate "Syntax of `defstruct'") -(defkeyword :print-function "Syntax of `defstruct'") -(defkeyword :type "Syntax of `defstruct'") -(defkeyword :initial-offset "Syntax of `defstruct'") - -(defkeyword :structure-doc "Documentation string for a structure.") -(defkeyword :structure-slotsn "Number of slots in structure") -(defkeyword :structure-slots "List of the slot's names") -(defkeyword :structure-indices "List of (KEYWORD-NAME . INDEX)") -(defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)") -(defkeyword :structure-includes - "() or list of a symbol, that this struct includes") -(defkeyword :structure-included-in - "List of the structs that include this") - - -(defmacro defstruct (&rest args) - "(defstruct NAME [DOC-STRING] . SLOTS) define NAME as structure type. -NAME must be a symbol, the name of the new structure. It could also -be a list (NAME . OPTIONS). - -Each option is either a symbol, or a list of a keyword symbol taken from the -list \{:conc-name, :copier, :constructor, :predicate, :include, -:print-function, :type, :initial-offset\}. The meanings of these are as in -CLtL, except that no BOA-constructors are provided, and the options -\{:print-function, :type, :initial-offset\} are ignored quietly. All these -structs are named, in the sense that their names can be used for type -discrimination. - -The DOC-STRING is established as the `structure-doc' property of NAME. - -The SLOTS are one or more of the following: -SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME -list of SYMBOL and VALUE -- meaning that VALUE is the initial value of -the slot. -`defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the -structure, and functions with the same name as the slots to access -them. `setf' of the accessors sets their values." - (multiple-value-bind - (name options docstring slotsn slots initlist) - (parse$defstruct$args args) - ;; Names for the member functions come from the options. The - ;; slots* stuff collects info about the slots declared explicitly. - (multiple-value-bind - (conc-name constructor copier predicate - moreslotsn moreslots moreinits included) - (parse$defstruct$options name options slots) - ;; The moreslots* stuff refers to slots gained as a consequence - ;; of (:include clauses). -- Oct 89: Only one :include tolerated - (when (and (numberp moreslotsn) - (> moreslotsn 0)) - (setf slotsn (+ slotsn moreslotsn)) - (setf slots (append moreslots slots)) - (setf initlist (append moreinits initlist))) - (unless (> slotsn 0) - (error "%s needs at least one slot" - (prin1-to-string name))) - (let ((dups (duplicate-symbols-p slots))) - (when dups - (error "`%s' are duplicates" - (prin1-to-string dups)))) - (setq initlist (simplify$inits slots initlist)) - (let (properties functions keywords accessors alterators returned) - ;; compute properties of NAME - (setq properties - (append - (list - (list 'put (list 'quote name) :structure-doc - docstring) - (list 'put (list 'quote name) :structure-slotsn - slotsn) - (list 'put (list 'quote name) :structure-slots - (list 'quote slots)) - (list 'put (list 'quote name) :structure-initforms - (list 'quote initlist)) - (list 'put (list 'quote name) :structure-indices - (list 'quote (extract$indices initlist)))) - ;; If this definition :includes another defstruct, - ;; modify both property lists. - (cond (included - (list - (list 'put - (list 'quote name) - :structure-includes - (list 'quote included)) - (list 'pushnew - (list 'quote name) - (list 'get (list 'quote (car included)) - :structure-included-in)))) - (t - (list - (let ((old (gensym))) - (list 'let - (list (list old - (list 'car - (list 'get - (list 'quote name) - :structure-includes)))) - (list 'when old - (list 'put - old - :structure-included-in - (list 'delq - (list 'quote name) - ;; careful with destructive - ;;manipulation! - (list - 'append - (list - 'get - old - :structure-included-in) - '()) - ))))) - (list 'put - (list 'quote name) - :structure-includes - '())))) - ;; If this definition used to be :included in another, warn - ;; that things make break. On the other hand, the redefinition - ;; may be trivial, so don't call it an error. - (let ((old (gensym))) - (list - (list 'let - (list (list old (list 'get - (list 'quote name) - :structure-included-in))) - (list 'when old - (list 'message - "`%s' redefined. Should redefine `%s'?" - (list 'quote name) - (list 'prin1-to-string old)))))))) - - ;; Compute functions associated with NAME. This is not - ;; handling BOA constructors yet, but here would be the place. - (setq functions - (list - (list 'fset (list 'quote constructor) - (list 'function - (list 'lambda (list '&rest 'args) - (list 'make$structure$instance - (list 'quote name) - 'args)))) - (list 'fset (list 'quote copier) - (list 'function 'copy-sequence)) - (let ((typetag (gensym))) - (list 'fset (list 'quote predicate) - (list - 'function - (list - 'lambda (list 'thing) - (list 'and - (list 'vectorp 'thing) - (list 'let - (list (list typetag - (list 'elt 'thing 0))) - (list 'or - (list - 'and - (list 'eq - typetag - (list 'quote name)) - (list '= - (list 'length 'thing) - (1+ slotsn))) - (list - 'memq - typetag - (list 'get - (list 'quote name) - :structure-included-in)))))) - ))))) - ;; compute accessors for NAME's slots - (multiple-value-setq - (accessors alterators keywords) - (build$accessors$for name conc-name predicate slots slotsn)) - ;; generate returned value -- not defined by the standard - (setq returned - (list - (cons 'vector - (mapcar - (function (lambda (x) (list 'quote x))) - (cons name slots))))) - ;; generate code - (cons 'progn - (nconc properties functions keywords - accessors alterators returned)))))) - -(defun parse$defstruct$args (args) - "(parse$defstruct$args ARGS) => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST -NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots, -SLOTS=list of their names, INITLIST=alist (keyword . initform)." - (let (name ;args=(symbol...) or ((symbol...)...) - options ;args=((symbol . options) ...) - (docstring "") ;args=(head docstring . slotargs) - slotargs ;second or third cdr of args - (slotsn 0) ;number of slots - (slots '()) ;list of slot names - (initlist '())) ;list of (slot keyword . initform) - ;; extract name and options - (cond ((symbolp (car args)) ;simple name - (setq name (car args) - options '())) - ((and (listp (car args)) ;(name . options) - (symbolp (caar args))) - (setq name (caar args) - options (cdar args))) - (t - (error "first arg to `defstruct' must be symbol or (symbol ...)"))) - (setq slotargs (cdr args)) - ;; is there a docstring? - (when (stringp (car slotargs)) - (setq docstring (car slotargs) - slotargs (cdr slotargs))) - ;; now for the slots - (multiple-value-bind - (slotsn slots initlist) - (process$slots slotargs) - (values name options docstring slotsn slots initlist)))) - -(defun process$slots (slots) - "(process$slots SLOTS) => SLOTSN SLOTSLIST INITLIST -Converts a list of symbols or lists of symbol and form into the last 3 -values returned by PARSE$DEFSTRUCT$ARGS." - (let ((slotsn (length slots)) ;number of slots - slotslist ;(slot1 slot2 ...) - initlist) ;((:slot1 . init1) ...) - (do* - ((ptr slots (cdr ptr)) - (this (car ptr) (car ptr))) - ((endp ptr)) - (cond ((symbolp this) - (setq slotslist (cons this slotslist)) - (setq initlist (acons (keyword-of this) nil initlist))) - ((and (listp this) - (symbolp (car this))) - (let ((name (car this)) - (form (cadr this))) - ;; this silently ignores any slot options. bad... - (setq slotslist (cons name slotslist)) - (setq initlist (acons (keyword-of name) form initlist)))) - (t - (error "slot should be symbol or (symbol ...), not `%s'" - (prin1-to-string this))))) - (values slotsn (nreverse slotslist) (nreverse initlist)))) - -(defun parse$defstruct$options (name options slots) - "(parse$defstruct$options name OPTIONS SLOTS) => many values -A defstruct named NAME, with options list OPTIONS, has already slots SLOTS. -Parse the OPTIONS and return the updated form of the struct's slots and other -information. The values returned are: - - CONC-NAME is the string to use as prefix/suffix in the methods, - CONST is the name of the official constructor, - COPIER is the name of the structure copier, - PRED is the name of the type predicate, - MORESLOTSN is the number of slots added by :include, - MORESLOTS is the list of slots added by :include, - MOREINITS is the list of initialization forms added by :include, - INCLUDED is nil, or the list of the symbol added by :include" - (let* ((namestring (symbol-name name)) - ;; to build the return values - (conc-name (concat namestring "-")) - (const (intern (concat "make-" namestring))) - (copier (intern (concat "copy-" namestring))) - (pred (intern (concat namestring "-p"))) - (moreslotsn 0) - (moreslots '()) - (moreinits '()) - ;; auxiliaries - option-head ;When an option is not a plain - option-second ; keyword, it must be a list of - option-rest ; the form (head second . rest) - these-slotsn ;When :include is found, the - these-slots ; info about the included - these-inits ; structure is added here. - included ;NIL or (list INCLUDED) - ) - ;; Values above are the defaults. Now we read the options themselves - (dolist (option options) - ;; 2 cases arise, as options must be a keyword or a list - (cond - ((keywordp option) - (case option - (:named - ) ;ignore silently - (t - (error "can't recognize option `%s'" - (prin1-to-string option))))) - ((and (listp option) - (keywordp (setq option-head (car option)))) - (setq option-second (second option)) - (setq option-rest (nthcdr 2 option)) - (case option-head - (:conc-name - (setq conc-name - (cond - ((stringp option-second) - option-second) - ((null option-second) - "") - (t - (error "`%s' is invalid as `conc-name'" - (prin1-to-string option-second)))))) - (:copier - (setq copier - (cond - ((and (symbolp option-second) - (null option-rest)) - option-second) - (t - (error "can't recognize option `%s'" - (prin1-to-string option)))))) - - (:constructor ;no BOA-constructors allowed - (setq const - (cond - ((and (symbolp option-second) - (null option-rest)) - option-second) - (t - (error "can't recognize option `%s'" - (prin1-to-string option)))))) - (:predicate - (setq pred - (cond - ((and (symbolp option-second) - (null option-rest)) - option-second) - (t - (error "can't recognize option `%s'" - (prin1-to-string option)))))) - (:include - (unless (symbolp option-second) - (error "arg to `:include' should be a symbol, not `%s'" - (prin1-to-string option-second))) - (setq these-slotsn (get option-second :structure-slotsn) - these-slots (get option-second :structure-slots) - these-inits (get option-second :structure-initforms)) - (unless (and (numberp these-slotsn) - (> these-slotsn 0)) - (error "`%s' is not a valid structure" - (prin1-to-string option-second))) - (if included - (error "`%s' already includes `%s', can't include `%s' too" - name (car included) option-second) - (push option-second included)) - (multiple-value-bind - (xtra-slotsn xtra-slots xtra-inits) - (process$slots option-rest) - (when (> xtra-slotsn 0) - (dolist (xslot xtra-slots) - (unless (memq xslot these-slots) - (error "`%s' is not a slot of `%s'" - (prin1-to-string xslot) - (prin1-to-string option-second)))) - (setq these-inits (append xtra-inits these-inits))) - (setq moreslotsn (+ moreslotsn these-slotsn)) - (setq moreslots (append these-slots moreslots)) - (setq moreinits (append these-inits moreinits)))) - ((:print-function :type :initial-offset) - ) ;ignore silently - (t - (error "can't recognize option `%s'" - (prin1-to-string option))))) - (t - (error "can't recognize option `%s'" - (prin1-to-string option))))) - ;; Return values found - (values conc-name const copier pred - moreslotsn moreslots moreinits - included))) - -(defun simplify$inits (slots initlist) - "(simplify$inits SLOTS INITLIST) => new INITLIST -Removes from INITLIST - an ALIST - any shadowed bindings." - (let ((result '()) ;built here - key ;from the slot - ) - (dolist (slot slots) - (setq key (keyword-of slot)) - (setq result (acons key (cdr (assoc key initlist)) result))) - (nreverse result))) - -(defun extract$indices (initlist) - "(extract$indices INITLIST) => indices list -Kludge. From a list of pairs (keyword . form) build a list of pairs -of the form (keyword . position in list from 0). Useful to precompute -some of the work of MAKE$STRUCTURE$INSTANCE." - (let ((result '()) - (index 0)) - (dolist (entry initlist (nreverse result)) - (setq result (acons (car entry) index result) - index (+ index 1))))) - -(defun build$accessors$for (name conc-name predicate slots slotsn) - "(build$accessors$for NAME PREDICATE SLOTS SLOTSN) => FSETS DEFSETFS KWDS -Generate the code for accesors and defsetfs of a structure called -NAME, whose slots are SLOTS. Also, establishes the keywords for the -slots names." - (do ((i 0 (1+ i)) - (accessors '()) - (alterators '()) - (keywords '()) - (canonic "")) ;slot name with conc-name prepended - ((>= i slotsn) - (values - (nreverse accessors) (nreverse alterators) (nreverse keywords))) - (setq canonic (intern (concat conc-name (symbol-name (nth i slots))))) - (setq accessors - (cons - (list 'fset (list 'quote canonic) - (list 'function - (list 'lambda (list 'object) - (list 'cond - (list (list predicate 'object) - (list 'aref 'object (1+ i))) - (list 't - (list 'error - "`%s' is not a struct %s" - (list 'prin1-to-string - 'object) - (list 'prin1-to-string - (list 'quote - name)))))))) - accessors)) - (setq alterators - (cons - (list 'defsetf canonic - (list 'lambda (list 'object 'newval) - (list 'cond - (list (list predicate 'object) - (list 'aset 'object (1+ i) 'newval)) - (list 't - (list 'error - "`%s' not a `%s'" - (list 'prin1-to-string - 'object) - (list 'prin1-to-string - (list 'quote - name))))))) - alterators)) - (setq keywords - (cons (list 'defkeyword (keyword-of (nth i slots))) - keywords)))) - -(defun make$structure$instance (name args) - "(make$structure$instance NAME ARGS) => new struct NAME -A struct of type NAME is created, some slots might be initialized -according to ARGS (the &rest argument of MAKE-name)." - (unless (symbolp name) - (error "`%s' is not a possible name for a structure" - (prin1-to-string name))) - (let ((initforms (get name :structure-initforms)) - (slotsn (get name :structure-slotsn)) - (indices (get name :structure-indices)) - initalist ;pairlis'd on initforms - initializers ;definitive initializers - ) - ;; check sanity of the request - (unless (and (numberp slotsn) - (> slotsn 0)) - (error "`%s' is not a defined structure" - (prin1-to-string name))) - (unless (evenp (length args)) - (error "slot initializers `%s' not of even length" - (prin1-to-string args))) - ;; analyze the initializers provided by the call - (multiple-value-bind - (speckwds specvals) ;keywords and values given - (unzip-list args) ; by the user - ;; check that all the arguments are introduced by keywords - (unless (every (function keywordp) speckwds) - (error "all of the names in `%s' should be keywords" - (prin1-to-string speckwds))) - ;; check that all the keywords are known - (dolist (kwd speckwds) - (unless (numberp (cdr (assoc kwd indices))) - (error "`%s' is not a valid slot name for %s" - (prin1-to-string kwd) (prin1-to-string name)))) - ;; update initforms - (setq initalist - (pairlis speckwds - (do* ;;protect values from further evaluation - ((ptr specvals (cdr ptr)) - (val (car ptr) (car ptr)) - (result '())) - ((endp ptr) (nreverse result)) - (setq result - (cons (list 'quote val) - result))) - (copy-sequence initforms))) - ;; compute definitive initializers - (setq initializers - (do* ;;gather the values of the most definitive forms - ((ptr indices (cdr ptr)) - (key (caar ptr) (caar ptr)) - (result '())) - ((endp ptr) (nreverse result)) - (setq result - (cons (eval (cdr (assoc key initalist))) result)))) - ;; do real initialization - (apply (function vector) - (cons name initializers))))) - -;;;; end of cl-structs.el - -;;; For lisp-interaction mode, so that multiple values can be seen when passed -;;; back. Lies every now and then... - -(defvar - nil "form currently under evaluation") -(defvar + nil "previous -") -(defvar ++ nil "previous +") -(defvar +++ nil "previous ++") -(defvar / nil "list of values returned by +") -(defvar // nil "list of values returned by ++") -(defvar /// nil "list of values returned by +++") -(defvar * nil "(first) value of +") -(defvar ** nil "(first) value of ++") -(defvar *** nil "(first) value of +++") - -(defun cl-eval-print-last-sexp () - "Evaluate sexp before point; print value\(s\) into current buffer. -If the evaled form returns multiple values, they are shown one to a line. -The variables -, +, ++, +++, *, **, ***, /, //, /// have their usual meaning. - -It clears the multiple-value passing mechanism, and does not pass back -multiple values. Use this only if you are debugging cl.el and understand well -how the multiple-value stuff works, because it can be fooled into believing -that multiple values have been returned when they actually haven't, for -instance - \(identity \(values nil 1\)\) -However, even when this fails, you can trust the first printed value to be -\(one of\) the returned value\(s\)." - (interactive) - ;; top level call, can reset mvalues - (setq *mvalues-count* nil - *mvalues-values* nil) - (setq - (car (read-from-string - (buffer-substring - (let ((stab (syntax-table))) - (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (forward-sexp -1) - (point)) - (set-syntax-table stab))) - (point))))) - (setq *** ** - ** * - * (eval -)) - (setq /// // - // / - / *mvalues-values*) - (setq +++ ++ - ++ + - + -) - (cond ((or (null *mvalues-count*) ;mvalues mechanism not used - (not (eq * (car *mvalues-values*)))) - (print * (current-buffer))) - ((null /) ;no values returned - (terpri (current-buffer))) - (t ;more than zero mvalues - (terpri (current-buffer)) - (mapcar (function (lambda (value) - (prin1 value (current-buffer)) - (terpri (current-buffer)))) - /))) - (setq *mvalues-count* nil ;make sure - *mvalues-values* nil)) - -;;;; More LISTS functions -;;;; - -;;; Some mapping functions on lists, commonly useful. -;;; They take no extra sequences, to go along with Emacs Lisp's MAPCAR. - -(defun mapc (function list) - "(MAPC FUNCTION LIST) => LIST -Apply FUNCTION to each element of LIST, return LIST. -Like mapcar, but called only for effect." - (let ((args list)) - (while args - (funcall function (car args)) - (setq args (cdr args)))) - list) - -(defun maplist (function list) - "(MAPLIST FUNCTION LIST) => list'ed results of FUNCTION on cdrs of LIST -Apply FUNCTION to successive sublists of LIST, return the list of the results" - (let ((args list) - results '()) - (while args - (setq results (cons (funcall function args) results) - args (cdr args))) - (nreverse results))) - -(defun mapl (function list) - "(MAPL FUNCTION LIST) => LIST -Apply FUNCTION to successive cdrs of LIST, return LIST. -Like maplist, but called only for effect." - (let ((args list)) - (while args - (funcall function args) - (setq args (cdr args))) - list)) - -(defun mapcan (function list) - "(MAPCAN FUNCTION LIST) => nconc'd results of FUNCTION on LIST -Apply FUNCTION to each element of LIST, nconc the results. -Beware: nconc destroys its first argument! See copy-list." - (let ((args list) - (results '())) - (while args - (setq results (nconc (funcall function (car args)) results) - args (cdr args))) - (nreverse results))) - -(defun mapcon (function list) - "(MAPCON FUNCTION LIST) => nconc'd results of FUNCTION on cdrs of LIST -Apply FUNCTION to successive sublists of LIST, nconc the results. -Beware: nconc destroys its first argument! See copy-list." - (let ((args list) - (results '())) - (while args - (setq results (nconc (funcall function args) results) - args (cdr args))) - (nreverse results))) - -;;; Copiers - -(defsubst copy-list (list) - "Build a copy of LIST" - (append list '())) - -(defun copy-tree (tree) - "Build a copy of the tree of conses TREE -The argument is a tree of conses, it is recursively copied down to -non conses. Circularity and sharing of substructure are not -necessarily preserved." - (if (consp tree) - (cons (copy-tree (car tree)) - (copy-tree (cdr tree))) - tree)) - -;;; reversals, and destructive manipulations of a list's spine - -(defun revappend (x y) - "does what (append (reverse X) Y) would, only faster" - (if (endp x) - y - (revappend (cdr x) (cons (car x) y)))) - -(defun nreconc (x y) - "does (nconc (nreverse X) Y) would, only faster -Destructive on X, be careful." - (if (endp x) - y - ;; reuse the first cons of x, making it point to y - (nreconc (cdr x) (prog1 x (rplacd x y))))) - -(defun nbutlast (list &optional n) - "Side-effected LIST truncated N+1 conses from the end. -This is the destructive version of BUTLAST. Returns () and does not -modify the LIST argument if the length of the list is not at least N." - (when (null n) (setf n 1)) - (let ((length (list-length list))) - (cond ((null length) - list) - ((< length n) - '()) - (t - (setnthcdr (- length n) list nil) - list)))) - -;;; Substitutions - -(defun subst (new old tree) - "NEW replaces OLD in a copy of TREE -Uses eql for the test." - (subst-if new (function (lambda (x) (eql x old))) tree)) - -(defun subst-if-not (new test tree) - "NEW replaces any subtree or leaf that fails TEST in a copy of TREE" - ;; (subst-if new (function (lambda (x) (not (funcall test x)))) tree) - (cond ((not (funcall test tree)) - new) - ((atom tree) - tree) - (t ;no match so far - (let ((head (subst-if-not new test (car tree))) - (tail (subst-if-not new test (cdr tree)))) - ;; If nothing changed, return originals. Else use the new - ;; components to assemble a new tree. - (if (and (eql head (car tree)) - (eql tail (cdr tree))) - tree - (cons head tail)))))) - -(defun subst-if (new test tree) - "NEW replaces any subtree or leaf that satisfies TEST in a copy of TREE" - (cond ((funcall test tree) - new) - ((atom tree) - tree) - (t ;no match so far - (let ((head (subst-if new test (car tree))) - (tail (subst-if new test (cdr tree)))) - ;; If nothing changed, return originals. Else use the new - ;; components to assemble a new tree. - (if (and (eql head (car tree)) - (eql tail (cdr tree))) - tree - (cons head tail)))))) - -(defun sublis (alist tree) - "Use association list ALIST to modify a copy of TREE -If a subtree or leaf of TREE is a key in ALIST, it is replaced by the -associated value. Not exactly Common Lisp, but close in spirit and -compatible with the native Emacs Lisp ASSOC, which uses EQUAL." - (let ((toplevel (assoc tree alist))) - (cond (toplevel ;Bingo at top - (cdr toplevel)) - ((atom tree) ;Give up on this - tree) - (t - (let ((head (sublis alist (car tree))) - (tail (sublis alist (cdr tree)))) - (if (and (eql head (car tree)) - (eql tail (cdr tree))) - tree - (cons head tail))))))) - -(defun member-if (predicate list) - "PREDICATE is applied to the members of LIST. As soon as one of them -returns true, that tail of the list if returned. Else NIL." - (catch 'found-member-if - (while (not (endp list)) - (if (funcall predicate (car list)) - (throw 'found-member-if list) - (setq list (cdr list)))) - nil)) - -(defun member-if-not (predicate list) - "PREDICATE is applied to the members of LIST. As soon as one of them -returns false, that tail of the list if returned. Else NIL." - (catch 'found-member-if-not - (while (not (endp list)) - (if (funcall predicate (car list)) - (setq list (cdr list)) - (throw 'found-member-if-not list))) - nil)) - -(defun tailp (sublist list) - "(tailp SUBLIST LIST) => True if SUBLIST is a sublist of LIST." - (catch 'tailp-found - (while (not (endp list)) - (if (eq sublist list) - (throw 'tailp-found t) - (setq list (cdr list)))) - nil)) - -;;; Suggestion of phr%widow.Berkeley.EDU@lilac.berkeley.edu - -(defmacro declare (&rest decls) - "Ignore a Common-Lisp declaration." - "declarations are ignored in this implementation") - -(defun proclaim (&rest decls) - "Ignore a Common-Lisp proclamation." - "declarations are ignored in this implementation") - -(defmacro the (type form) - "(the TYPE FORM) macroexpands to FORM -No checking is even attempted. This is just for compatibility with -Common-Lisp codes." - form) - -;;; Due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) -(put 'progv 'common-lisp-indent-hook '(4 4 &body)) -(defmacro progv (vars vals &rest body) - "progv vars vals &body forms -bind vars to vals then execute forms. -If there are more vars than vals, the extra vars are unbound, if -there are more vals than vars, the extra vals are just ignored." - (` (progv$runtime (, vars) (, vals) (function (lambda () (,@ body)))))) - -;;; To do this efficiently, it really needs to be a special form... -(defun progv$runtime (vars vals body) - (eval (let ((vars-n-vals nil) - (unbind-forms nil)) - (do ((r vars (cdr r)) - (l vals (cdr l))) - ((endp r)) - (push (list (car r) (list 'quote (car l))) vars-n-vals) - (if (null l) - (push (` (makunbound '(, (car r)))) unbind-forms))) - (` (let (, vars-n-vals) (,@ unbind-forms) (funcall '(, body))))))) - -(provide 'cl) - -;;;; end of cl.el
--- a/lisp/=cmulisp.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,694 +0,0 @@ -;;; cmulisp.el --- improved version of standard inferior-lisp mode - -;;; Copyright Olin Shivers (1988). - -;; Keywords: processes, lisp - -;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright -;;; notice appearing here to the effect that you may use this code any -;;; way you like, as long as you don't charge money for it, remove this -;;; notice, or hold me liable for its results. - -;;; Commentary: - -;;; This replaces the standard inferior-lisp mode. -;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 -;;; Please send me bug reports, bug fixes, and extensions, so that I can -;;; merge them into the master source. -;;; -;;; Change log at end of file. - -;;; This file defines a a lisp-in-a-buffer package (cmulisp mode) built on top -;;; of comint mode. Cmulisp mode is similar to, and intended to replace, its -;;; counterpart in the standard gnu emacs release. This replacements is more -;;; featureful, robust, and uniform than the released version. The key -;;; bindings are also more compatible with the bindings of Hemlock and Zwei -;;; (the Lisp Machine emacs). - -;;; Since this mode is built on top of the general command-interpreter-in- -;;; a-buffer mode (comint mode), it shares a common base functionality, -;;; and a common set of bindings, with all modes derived from comint mode. -;;; This makes these modes easier to use. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customising it, see the file comint.el. -;;; For further information on cmulisp mode, see the comments below. - -;;; Needs fixin: -;;; 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, ...). -;;; -;;; It would be nice if cmulisp (and inferior scheme, T, ...) modes -;;; had a verbose minor mode wherein sending or compiling defuns, etc. -;;; would be reflected in the transcript with suitable comments, e.g. -;;; ";;; redefining fact". Several ways to do this. Which is right? -;;; -;;; When sending text from a source file to a subprocess, the process-mark can -;;; move off the window, so you can lose sight of the process interactions. -;;; Maybe I should ensure the process mark is in the window when I send -;;; text to the process? Switch selectable? - -(require 'comint) -;; YOUR .EMACS FILE -;;============================================================================= -;; Some suggestions for your .emacs file. -;; -;; ; If cmulisp lives in some non-standard directory, you must tell emacs -;; ; where to get it. This may or may not be necessary. -;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path)) -;; -;; ; Autoload cmulisp from file cmulisp.el -;; (autoload 'cmulisp "cmulisp" -;; "Run an inferior Lisp process." -;; t) -;; -;; ; Define C-c t to run my favorite command in cmulisp mode: -;; (setq cmulisp-load-hook -;; '((lambda () -;; (define-key cmulisp-mode-map "\C-ct" 'favorite-cmd)))) - -;; Brief Command Documentation: -;;============================================================================ -;; Comint Mode Commands: (common to cmulisp and all comint-derived modes) -;; -;; m-p comint-previous-input Cycle backwards in input history -;; m-n comint-next-input Cycle forwards -;; m-c-r comint-previous-input-matching Search backwards in input history -;; return comint-send-input -;; c-a comint-bol Beginning of line; skip prompt. -;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. -;; 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-kill-output Delete last batch of process output -;; c-c c-r comint-show-output Show last batch of process output -;; send-invisible Read line w/o echo & send to proc -;; comint-continue-subjob Useful if you accidentally suspend -;; top-level job. -;; comint-mode-hook is the comint mode hook. - -;; CMU Lisp Mode Commands: -;; c-m-x lisp-send-defun This binding is a gnu convention. -;; c-c c-l lisp-load-file Prompt for file name; tell Lisp to load it. -;; c-c c-k lisp-compile-file Prompt for file name; tell Lisp to kompile it. -;; Filename completion is available, of course. -;; -;; Additionally, these commands are added to the key bindings of Lisp mode: -;; c-m-x lisp-eval-defun This binding is a gnu convention. -;; c-c c-e lisp-eval-defun Send the current defun to Lisp process. -;; c-x c-e lisp-eval-last-sexp Send the previous sexp to Lisp process. -;; c-c c-r lisp-eval-region Send the current region to Lisp process. -;; c-c c-c lisp-compile-defun Compile the current defun in Lisp process. -;; c-c c-z switch-to-lisp Switch to the Lisp process buffer. -;; c-c c-l lisp-load-file (See above. In a Lisp file buffer, default -;; c-c c-k lisp-compile-file is to load/compile the current file.) -;; c-c c-d lisp-describe-sym Query Lisp for a symbol's description. -;; c-c c-a lisp-show-arglist Query Lisp for function's arglist. -;; c-c c-f lisp-show-function-documentation Query Lisp for a function's doc. -;; c-c c-v lisp-show-variable-documentation Query Lisp for a variable's doc. - -;; cmulisp Fires up the Lisp process. -;; lisp-compile-region Compile all forms in the current region. -;; -;; CMU Lisp Mode Variables: -;; cmulisp-filter-regexp Match this => don't get saved on input hist -;; inferior-lisp-program Name of Lisp program run-lisp executes -;; inferior-lisp-load-command Customises lisp-load-file -;; cmulisp-mode-hook -;; inferior-lisp-prompt Initialises comint-prompt-regexp. -;; Backwards compatibility. -;; lisp-source-modes Anything loaded into a buffer that's in -;; one of these modes is considered Lisp -;; source by lisp-load/compile-file. - -;;; Code: - -(require 'comint) - -;;; Read the rest of this file for more information. - - -;;; Code: - -(defvar cmulisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'" - "*What not to save on inferior Lisp's input history -Input matching this regexp is not saved on the input history in cmulisp -mode. Default is whitespace followed by 0 or 1 single-letter :keyword -(as in :a, :c, etc.)") - -(defvar cmulisp-mode-map nil) -(cond ((not cmulisp-mode-map) - (setq cmulisp-mode-map - (nconc (full-copy-sparse-keymap comint-mode-map) - shared-lisp-mode-map)) - (define-key cmulisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) - (define-key cmulisp-mode-map "\C-c\C-l" 'lisp-load-file) - (define-key cmulisp-mode-map "\C-c\C-k" 'lisp-compile-file) - (define-key cmulisp-mode-map "\C-c\C-a" 'lisp-show-arglist) - (define-key cmulisp-mode-map "\C-c\C-d" 'lisp-describe-sym) - (define-key cmulisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) - (define-key cmulisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation))) - -;;; These commands augment Lisp mode, so you can process Lisp code in -;;; the source files. -(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention -(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention -(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun) -(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region) -(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun) -(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp) -(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file) -(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file -(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) -(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) -(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) -(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation) - -(defvar cmulisp-buffer) - -;;; This function exists for backwards compatibility. -;;; Previous versions of this package bound commands to C-c <letter> -;;; bindings, which is not allowed by the gnumacs standard. - -(defun cmulisp-install-letter-bindings () - "This function binds many cmulisp commands to C-c <letter> bindings, -where they are more accessible. C-c <letter> bindings are reserved for the -user, so these bindings are non-standard. If you want them, you should -have this function called by the cmulisp-load-hook: - (setq cmulisp-load-hook '(cmulisp-install-letter-bindings)) -You can modify this function to install just the bindings you want." - - (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go) - (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go) - (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go) - (define-key lisp-mode-map "\C-cz" 'switch-to-lisp) - (define-key lisp-mode-map "\C-cl" 'lisp-load-file) - (define-key lisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation) - - (define-key cmulisp-mode-map "\C-cl" 'lisp-load-file) - (define-key cmulisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key cmulisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key cmulisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key cmulisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key cmulisp-mode-map "\C-cv" 'lisp-show-variable-documentation)) - - -(defvar inferior-lisp-program "lisp" - "*Program name for invoking an inferior Lisp with `cmulisp'.") - -(defvar inferior-lisp-load-command "(load \"%s\")\n" - "*Format-string for building a Lisp expression to load a file. -This format string should use %s to substitute a file name -and should result in a Lisp expression that will command the inferior Lisp -to load that file. The default works acceptably on most Lisps. -The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\" -produces cosmetically superior output for this application, -but it works only in Common Lisp.") - -(defvar inferior-lisp-prompt "^[^> ]*>+:? *" - "Regexp to recognise prompts in the inferior Lisp. -Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl, -and franz. This variable is used to initialise comint-prompt-regexp in the -cmulisp buffer. - -More precise choices: -Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" -franz: \"^\\(->\\|<[0-9]*>:\\) *\" -kcl: \"^>+ *\" - -This is a fine thing to set in your .emacs file.") - -(defvar cmulisp-mode-hook '() - "*Hook for customising cmulisp mode") - -(defun cmulisp-mode () - "Major mode for interacting with an inferior Lisp process. -Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an -Emacs buffer. Variable inferior-lisp-program controls which Lisp interpreter -is run. Variables inferior-lisp-prompt, cmulisp-filter-regexp and -inferior-lisp-load-command can customize this mode for different Lisp -interpreters. - -For information on running multiple processes in multiple buffers, see -documentation for variable cmulisp-buffer. - -\\{cmulisp-mode-map} - -Customisation: Entry to this mode runs the hooks on comint-mode-hook and -cmulisp-mode-hook (in that order). - -You can send text to the inferior Lisp process from other buffers containing -Lisp source. - switch-to-lisp switches the current buffer to the Lisp process buffer. - lisp-eval-defun sends the current defun to the Lisp process. - lisp-compile-defun compiles the current defun. - lisp-eval-region sends the current region to the Lisp process. - lisp-compile-region compiles the current region. - - Prefixing the lisp-eval/compile-defun/region commands with - a \\[universal-argument] causes a switch to the Lisp process buffer after sending - the text. - -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 Lisp; 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." - (interactive) - (comint-mode) - (setq comint-prompt-regexp inferior-lisp-prompt) - (setq major-mode 'cmulisp-mode) - (setq mode-name "CMU Lisp") - (setq mode-line-process '(": %s")) - (lisp-mode-variables t) - (use-local-map cmulisp-mode-map) ;c-c c-k for "kompile" file - (setq comint-get-old-input (function lisp-get-old-input)) - (setq comint-input-filter (function lisp-input-filter)) - (setq comint-input-sentinel 'ignore) - (run-hooks 'cmulisp-mode-hook)) - -(defun lisp-get-old-input () - "Snarf the sexp ending at point" - (save-excursion - (let ((end (point))) - (backward-sexp) - (buffer-substring (point) end)))) - -(defun lisp-input-filter (str) - "Don't save anything matching cmulisp-filter-regexp" - (not (string-match cmulisp-filter-regexp str))) - -(defun cmulisp (cmd) - "Run an inferior Lisp process, input and output via buffer *cmulisp*. -If there is a process already running in *cmulisp*, just switch to that buffer. -With argument, allows you to edit the command line (default is value -of inferior-lisp-program). Runs the hooks from cmulisp-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 lisp: " inferior-lisp-program) - inferior-lisp-program))) - (if (not (comint-check-proc "*cmulisp*")) - (let ((cmdlist (cmulisp-args-to-list cmd))) - (set-buffer (apply (function make-comint) "cmulisp" (car cmdlist) nil - (cdr cmdlist))) - (cmulisp-mode))) - (setq cmulisp-buffer "*cmulisp*") - (switch-to-buffer "*cmulisp*")) - -;;; Break a string up into a list of arguments. -;;; This will break if you have an argument with whitespace, as in -;;; string = "-ab +c -x 'you lose'". -(defun cmulisp-args-to-list (string) - (let ((where (string-match "[ \t]" string))) - (cond ((null where) (list string)) - ((not (= where 0)) - (cons (substring string 0 where) - (tea-args-to-list (substring string (+ 1 where) - (length string))))) - (t (let ((pos (string-match "[^ \t]" string))) - (if (null pos) - nil - (cmulisp-args-to-list (substring string pos - (length string))))))))) - -(defun lisp-eval-region (start end &optional and-go) - "Send the current region to the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "r\nP") - (comint-send-region (cmulisp-proc) start end) - (comint-send-string (cmulisp-proc) "\n") - (if and-go (switch-to-lisp t))) - -(defun lisp-eval-defun (&optional and-go) - "Send the current defun to the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "P") - (save-excursion - (end-of-defun) - (skip-chars-backward " \t\n\r\f") ; Makes allegro happy - (let ((end (point))) - (beginning-of-defun) - (lisp-eval-region (point) end))) - (if and-go (switch-to-lisp t))) - -(defun lisp-eval-last-sexp (&optional and-go) - "Send the previous sexp to the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "P") - (lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go)) - -;;; Common Lisp COMPILE sux. -(defun lisp-compile-region (start end &optional and-go) - "Compile the current region in the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "r\nP") - (comint-send-string (cmulisp-proc) - (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n" - (buffer-substring start end))) - (if and-go (switch-to-lisp t))) - -(defun lisp-compile-defun (&optional and-go) - "Compile the current defun in the inferior Lisp process. -Prefix argument means switch-to-lisp afterwards." - (interactive "P") - (save-excursion - (end-of-defun) - (skip-chars-backward " \t\n\r\f") ; Makes allegro happy - (let ((e (point))) - (beginning-of-defun) - (lisp-compile-region (point) e))) - (if and-go (switch-to-lisp t))) - -(defun switch-to-lisp (eob-p) - "Switch to the inferior Lisp process buffer. -With argument, positions cursor at end of buffer." - (interactive "P") - (if (get-buffer cmulisp-buffer) - (pop-to-buffer cmulisp-buffer) - (error "No current process buffer. See variable cmulisp-buffer.")) - (cond (eob-p - (push-mark) - (goto-char (point-max))))) - - -;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg, -;;; these commands are redundant. But they are kept around for the user -;;; to bind if he wishes, for backwards functionality, and because it's -;;; easier to type C-c e than C-u C-c C-e. - -(defun lisp-eval-region-and-go (start end) - "Send the current region to the inferior Lisp, -and switch to the process buffer." - (interactive "r") - (lisp-eval-region start end t)) - -(defun lisp-eval-defun-and-go () - "Send the current defun to the inferior Lisp, -and switch to the process buffer." - (interactive) - (lisp-eval-defun t)) - -(defun lisp-compile-region-and-go (start end) - "Compile the current region in the inferior Lisp, -and switch to the process buffer." - (interactive "r") - (lisp-compile-region start end t)) - -(defun lisp-compile-defun-and-go () - "Compile the current defun in the inferior Lisp, -and switch to the process buffer." - (interactive) - (lisp-compile-defun t)) - -;;; A version of the form in H. Shevis' soar-mode.el package. Less robust. -;(defun lisp-compile-sexp (start end) -; "Compile the s-expression bounded by START and END in the inferior lisp. -;If the sexp isn't a DEFUN form, it is evaluated instead." -; (cond ((looking-at "(defun\\s +") -; (goto-char (match-end 0)) -; (let ((name-start (point))) -; (forward-sexp 1) -; (process-send-string "cmulisp" (format "(compile '%s #'(lambda " -; (buffer-substring name-start -; (point))))) -; (let ((body-start (point))) -; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun. -; (process-send-region "cmulisp" (buffer-substring body-start (point)))) -; (process-send-string "cmulisp" ")\n")) -; (t (lisp-eval-region start end))))) -; -;(defun lisp-compile-region (start end) -; "Each s-expression in the current region is compiled (if a DEFUN) -;or evaluated (if not) in the inferior lisp." -; (interactive "r") -; (save-excursion -; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check -; (if (< (point) start) (error "region begins in middle of defun")) -; (goto-char start) -; (let ((s start)) -; (end-of-defun) -; (while (<= (point) end) ; Zip through -; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks. -; (setq s (point)) -; (end-of-defun)) -; (if (< s end) (lisp-compile-sexp s end))))) -;;; -;;; End of HS-style code - - -(defvar lisp-prev-l/c-dir/file nil - "Saves the (directory . file) pair used in the last lisp-load-file or -lisp-compile-file command. Used for determining the default in the -next one.") - -(defvar lisp-source-modes '(lisp-mode) - "*Used to determine if a buffer contains Lisp source code. -If it's loaded into a buffer that is in one of these major modes, it's -considered a Lisp source file by lisp-load-file and lisp-compile-file. -Used by these commands to determine defaults.") - -(defun lisp-load-file (file-name) - "Load a Lisp file into the inferior Lisp process." - (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) ; NIL because LOAD - ; doesn't need an exact name - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (cmulisp-proc) - (format inferior-lisp-load-command file-name)) - (switch-to-lisp t)) - - -(defun lisp-compile-file (file-name) - "Compile a Lisp file in the inferior Lisp process." - (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file - lisp-source-modes nil)) ; NIL = don't need - ; suffix .lisp - (comint-check-source file-name) ; Check to see if buffer needs saved. - (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name) - (file-name-nondirectory file-name))) - (comint-send-string (cmulisp-proc) (concat "(compile-file \"" - file-name - "\"\)\n")) - (switch-to-lisp t)) - - - -;;; Documentation functions: function doc, var doc, arglist, and -;;; describe symbol. -;;; =========================================================================== - -;;; Command strings -;;; =============== - -(defvar lisp-function-doc-command - "(let ((fn '%s)) - (format t \"Documentation for ~a:~&~a\" - fn (documentation fn 'function)) - (values))\n" - "Command to query inferior Lisp for a function's documentation.") - -(defvar lisp-var-doc-command - "(let ((v '%s)) - (format t \"Documentation for ~a:~&~a\" - v (documentation v 'variable)) - (values))\n" - "Command to query inferior Lisp for a variable's documentation.") - -(defvar lisp-arglist-command - "(let ((fn '%s)) - (format t \"Arglist for ~a: ~a\" fn (arglist fn)) - (values))\n" - "Command to query inferior Lisp for a function's arglist.") - -(defvar lisp-describe-sym-command - "(describe '%s)\n" - "Command to query inferior Lisp for a variable's documentation.") - - -;;; Ancillary functions -;;; =================== - -;;; Reads a string from the user. -(defun lisp-symprompt (prompt default) - (list (let* ((prompt (if default - (format "%s (default %s): " prompt default) - (concat prompt ": "))) - (ans (read-string prompt))) - (if (zerop (length ans)) default ans)))) - - -;;; Adapted from function-called-at-point in help.el. -(defun lisp-fn-called-at-pt () - "Returns the name of the function called in the current call. -Nil if it can't find one." - (condition-case nil - (save-excursion - (save-restriction - (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) - (backward-up-list 1) - (forward-char 1) - (let ((obj (read (current-buffer)))) - (and (symbolp obj) obj)))) - (error nil))) - - -;;; Adapted from variable-at-point in help.el. -(defun lisp-var-at-pt () - (condition-case () - (save-excursion - (forward-sexp -1) - (skip-chars-forward "'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) obj))) - (error nil))) - - -;;; Documentation functions: fn and var doc, arglist, and symbol describe. -;;; ====================================================================== - -(defun lisp-show-function-documentation (fn) - "Send a command to the inferior Lisp to give documentation for function FN. -See variable lisp-function-doc-command." - (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt))) - (comint-proc-query (cmulisp-proc) (format lisp-function-doc-command fn))) - -(defun lisp-show-variable-documentation (var) - "Send a command to the inferior Lisp to give documentation for function FN. -See variable lisp-var-doc-command." - (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt))) - (comint-proc-query (cmulisp-proc) (format lisp-var-doc-command var))) - -(defun lisp-show-arglist (fn) - "Sends an query to the inferior Lisp for the arglist for function FN. -See variable lisp-arglist-command." - (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt))) - (comint-proc-query (cmulisp-proc) (format lisp-arglist-command fn))) - -(defun lisp-describe-sym (sym) - "Send a command to the inferior Lisp to describe symbol SYM. -See variable lisp-describe-sym-command." - (interactive (lisp-symprompt "Describe" (lisp-var-at-pt))) - (comint-proc-query (cmulisp-proc) (format lisp-describe-sym-command sym))) - - -(defvar cmulisp-buffer nil "*The current cmulisp process buffer. - -MULTIPLE PROCESS SUPPORT -=========================================================================== -Cmulisp.el supports, in a fairly simple fashion, running multiple Lisp -processes. To run multiple Lisp processes, you start the first up with -\\[cmulisp]. It will be in a buffer named *cmulisp*. Rename this buffer -with \\[rename-buffer]. You may now start up a new process with another -\\[cmulisp]. It will be in a new buffer, named *cmulisp*. You can -switch between the different process buffers with \\[switch-to-buffer]. - -Commands that send text from source buffers to Lisp processes -- -like lisp-eval-defun or lisp-show-arglist -- have to choose a process -to send to, when you have more than one Lisp process around. This -is determined by the global variable cmulisp-buffer. Suppose you -have three inferior lisps running: - Buffer Process - foo cmulisp - bar cmulisp<2> - *cmulisp* cmulisp<3> -If you do a \\[lisp-eval-defun] command on some Lisp source code, -what process do you send it to? - -- If you're in a process buffer (foo, bar, or *cmulisp*), - 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 cmulisp-buffer. -This process selection is performed by function cmulisp-proc. - -Whenever \\[cmulisp] fires up a new process, it resets cmulisp-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 -cmulisp-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 processes. The approach taken here is for a -minimal, simple implementation. Feel free to extend it.") - -(defun cmulisp-proc () - "Returns the current cmulisp process. See variable cmulisp-buffer." - (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode) - (current-buffer) - cmulisp-buffer)))) - (or proc - (error "No current process. See variable cmulisp-buffer")))) - - -;;; Do the user's customisation... -;;;=============================== -(defvar cmulisp-load-hook nil - "This hook is run when cmulisp is loaded in. -This is a good place to put keybindings.") - -(run-hooks 'cmulisp-load-hook) - -;;; CHANGE LOG -;;; =========================================================================== -;;; 5/24/90 Olin -;;; - Split cmulisp and cmushell modes into separate files. -;;; Not only is this a good idea, it's apparently the way it'll be rel 19. -;;; - Upgraded process sends to use comint-send-string instead of -;;; process-send-string. -;;; - Explicit references to process "cmulisp" have been replaced with -;;; (cmulisp-proc). This allows better handling of multiple process bufs. -;;; - Added process query and var/function/symbol documentation -;;; commands. Based on code written by Douglas Roberts. -;;; - Added lisp-eval-last-sexp, bound to C-x C-e. -;;; -;;; 9/20/90 Olin -;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix -;;; reported by Lennart Staflin. -;;; -;;; 3/12/90 Olin -;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp. -;;; Tale suggested this. -;;; - Reversed this decision 7/15/91. You need the visual feedback. -;;; -;;; 7/25/91 Olin -;;; Changed all keybindings of the form C-c <letter>. These are -;;; supposed to be reserved for the user to bind. This affected -;;; mainly the compile/eval-defun/region[-and-go] commands. -;;; This was painful, but necessary to adhere to the gnumacs standard. -;;; For some backwards compatibility, see the -;;; cmulisp-install-letter-bindings -;;; function. -;;; -;;; 8/2/91 Olin -;;; - The lisp-compile/eval-defun/region commands now take a prefix arg, -;;; which means switch-to-lisp after sending the text to the Lisp process. -;;; This obsoletes all the -and-go commands. The -and-go commands are -;;; kept around for historical reasons, and because the user can bind -;;; them to key sequences shorter than C-u C-c C-<letter>. -;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to -;;; edit the command line. - -(provide 'cmulisp) - -;;; cmulisp.el ends here
--- a/lisp/=custom.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2472 +0,0 @@ -;;; custom.el --- User friendly customization support. - -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. - -;; Author: Per Abrahamsen <abraham@iesd.auc.dk> -;; Keywords: help -;; Version: 0.5 - -;; 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: - -;; WARNING: This package is still under construction and not all of -;; the features below are implemented. -;; -;; This package provides a framework for adding user friendly -;; customization support to Emacs. Having to do customization by -;; editing a text file in some arcane syntax is user hostile in the -;; extreme, and to most users emacs lisp definitely count as arcane. -;; -;; The intent is that authors of emacs lisp packages declare the -;; variables intended for user customization with `custom-declare'. -;; Custom can then automatically generate a customization buffer with -;; `custom-buffer-create' where the user can edit the package -;; variables in a simple and intuitive way, as well as a menu with -;; `custom-menu-create' where he can set the more commonly used -;; variables interactively. -;; -;; It is also possible to use custom for modifying the properties of -;; other objects than the package itself, by specifying extra optional -;; arguments to `custom-buffer-create'. -;; -;; Custom is inspired by OPEN LOOK property windows. - -;;; Todo: -;; -;; - Toggle documentation in three states `none', `one-line', `full'. -;; - Function to generate an XEmacs menu from a CUSTOM. -;; - Write TeXinfo documentation. -;; - Make it possible to hide sections by clicking at the level. -;; - Declare AUC TeX variables. -;; - Declare (ding) Gnus variables. -;; - Declare Emacs variables. -;; - Implement remaining types. -;; - XEmacs port. -;; - Allow `URL', `info', and internal hypertext buttons. -;; - Support meta-variables and goal directed customization. -;; - Make it easy to declare custom types independently. -;; - Make it possible to declare default value and type for a single -;; variable, storing the data in a symbol property. -;; - Syntactic sugar for CUSTOM declarations. -;; - Use W3 for variable documentation. - -;;; Code: - -(eval-when-compile - (require 'cl)) - -;;; Compatibility: - -(defun custom-xmas-add-text-properties (start end props &optional object) - (add-text-properties start end props object) - (put-text-property start end 'start-open t object) - (put-text-property start end 'end-open t object)) - -(defun custom-xmas-put-text-property (start end prop value &optional object) - (put-text-property start end prop value object) - (put-text-property start end 'start-open t object) - (put-text-property start end 'end-open t object)) - -(defun custom-xmas-extent-start-open () - (map-extents (lambda (extent arg) - (set-extent-property extent 'start-open t)) - nil (point) (min (1+ (point)) (point-max)))) - -(if (string-match "XEmacs\\|Lucid" emacs-version) - (progn - (fset 'custom-add-text-properties 'custom-xmas-add-text-properties) - (fset 'custom-put-text-property 'custom-xmas-put-text-property) - (fset 'custom-extent-start-open 'custom-xmas-extent-start-open) - (fset 'custom-set-text-properties - (if (fboundp 'set-text-properties) - 'set-text-properties)) - (fset 'custom-buffer-substring-no-properties - (if (fboundp 'buffer-substring-no-properties) - 'buffer-substring-no-properties - 'custom-xmas-buffer-substring-no-properties))) - (fset 'custom-add-text-properties 'add-text-properties) - (fset 'custom-put-text-property 'put-text-property) - (fset 'custom-extent-start-open 'ignore) - (fset 'custom-set-text-properties 'set-text-properties) - (fset 'custom-buffer-substring-no-properties - 'buffer-substring-no-properties)) - -(defun custom-xmas-buffer-substring-no-properties (beg end) - "Return the text from BEG to END, without text properties, as a string." - (let ((string (buffer-substring beg end))) - (custom-set-text-properties 0 (length string) nil string) - string)) - -(or (fboundp 'add-to-list) - ;; Introduced in Emacs 19.29. - (defun add-to-list (list-var element) - "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. -If you want to use `add-to-list' on a variable that is not defined -until a certain package is loaded, you should put the call to `add-to-list' -into a hook function that will be run only after loading the package. -`eval-after-load' provides one way to do this. In some cases -other hooks, such as major mode hooks, can do the job." - (or (member element (symbol-value list-var)) - (set list-var (cons element (symbol-value list-var)))))) - -(or (fboundp 'plist-get) - ;; Introduced in Emacs 19.29. - (defun plist-get (plist prop) - "Extract a value from a property list. -PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value -corresponding to the given PROP, or nil if PROP is not -one of the properties on the list." - (let (result) - (while plist - (if (eq (car plist) prop) - (setq result (car (cdr plist)) - plist nil) - (set plist (cdr (cdr plist))))) - result))) - -(or (fboundp 'plist-put) - ;; Introduced in Emacs 19.29. - (defun plist-put (plist prop val) - "Change value in PLIST of PROP to VAL. -PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object. -If PROP is already a property on the list, its value is set to VAL, -otherwise the new PROP VAL pair is added. The new plist is returned; -use `(setq x (plist-put x prop val))' to be sure to use the new value. -The PLIST is modified by side effects." - (if (null plist) - (list prop val) - (let ((current plist)) - (while current - (cond ((eq (car current) prop) - (setcar (cdr current) val) - (setq current nil)) - ((null (cdr (cdr current))) - (setcdr (cdr current) (list prop val)) - (setq current nil)) - (t - (setq current (cdr (cdr current))))))) - plist))) - -(or (fboundp 'match-string) - ;; Introduced in Emacs 19.29. - (defun match-string (num &optional string) - "Return string of text matched by last search. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING." - (if (match-beginning num) - (if string - (substring string (match-beginning num) (match-end num)) - (buffer-substring (match-beginning num) (match-end num)))))) - -(or (fboundp 'facep) - ;; Introduced in Emacs 19.29. - (defun facep (x) - "Return t if X is a face name or an internal face vector." - (and (or (and (fboundp 'internal-facep) (internal-facep x)) - (and - (symbolp x) - (assq x (and (boundp 'global-face-data) global-face-data)))) - t))) - -;; XEmacs and Emacs 19.29 facep does different things. -(if (fboundp 'find-face) - (fset 'custom-facep 'find-face) - (fset 'custom-facep 'facep)) - -(if (custom-facep 'underline) - () - ;; No underline face in XEmacs 19.12. - (and (fboundp 'make-face) - (funcall (intern "make-face") 'underline)) - ;; Must avoid calling set-face-underline-p directly, because it - ;; is a defsubst in emacs19, and will make the .elc files non - ;; portable! - (or (and (fboundp 'face-differs-from-default-p) - (face-differs-from-default-p 'underline)) - (and (fboundp 'set-face-underline-p) - (funcall 'set-face-underline-p 'underline t)))) - -(defun custom-xmas-set-text-properties (start end props &optional buffer) - (if (null buffer) - (if props - (while props - (custom-put-text-property - start end (car props) (nth 1 props) buffer) - (setq props (nthcdr 2 props))) - (remove-text-properties start end ())))) - -(or (fboundp 'event-point) - ;; Missing in Emacs 19.29. - (defun event-point (event) - "Return the character position of the given mouse-motion, button-press, -or button-release event. If the event did not occur over a window, or did -not occur over text, then this returns nil. Otherwise, it returns an index -into the buffer visible in the event's window." - (posn-point (event-start event)))) - -(eval-when-compile - (defvar x-colors nil) - (defvar custom-button-face nil) - (defvar custom-field-uninitialized-face nil) - (defvar custom-field-invalid-face nil) - (defvar custom-field-modified-face nil) - (defvar custom-field-face nil) - (defvar custom-mouse-face nil) - (defvar custom-field-active-face nil)) - -;; We can't easily check for a working intangible. -(defconst intangible (if (and (boundp 'emacs-minor-version) - (or (> emacs-major-version 19) - (and (> emacs-major-version 18) - (> emacs-minor-version 28)))) - (setq intangible 'intangible) - (setq intangible 'intangible-if-it-had-been-working)) - "The symbol making text intangible.") - -(defconst rear-nonsticky (if (string-match "XEmacs" emacs-version) - 'end-open - 'rear-nonsticky) - "The symbol making text properties non-sticky in the rear end.") - -(defconst front-sticky (if (string-match "XEmacs" emacs-version) - 'front-closed - 'front-sticky) - "The symbol making text properties sticky in the front.") - -(defconst mouse-face (if (string-match "XEmacs" emacs-version) - 'highlight - 'mouse-face) - "Symbol used for highlighting text under mouse.") - -;; Put it in the Help menu, if possible. -(if (string-match "XEmacs" emacs-version) - (if (featurep 'menubar) - ;; XEmacs (disabled because it doesn't work) - (and current-menubar - (add-menu-item '("Help") "Customize..." 'customize t))) - ;; Emacs 19.28 and earlier - (global-set-key [ menu-bar help customize ] - '("Customize..." . customize)) - ;; Emacs 19.29 and later - (global-set-key [ menu-bar help-menu customize ] - '("Customize..." . customize))) - -;; XEmacs popup-menu stolen from w3.el. -(defun custom-x-really-popup-menu (pos title menudesc) - "My hacked up function to do a blocking popup menu..." - (let ((echo-keystrokes 0) - event menu) - (while menudesc - (setq menu (cons (vector (car (car menudesc)) - (list (car (car menudesc))) t) menu) - menudesc (cdr menudesc))) - (setq menu (cons title menu)) - (popup-menu menu) - (catch 'popup-done - (while t - (setq event (next-command-event event)) - (cond ((and (misc-user-event-p event) (stringp (car-safe (event-object event)))) - (throw 'popup-done (event-object event))) - ((and (misc-user-event-p event) - (or (eq (event-object event) 'abort) - (eq (event-object event) 'menu-no-selection-hook))) - nil) - ((not (popup-menu-up-p)) - (throw 'popup-done nil)) - ((button-release-event-p event);; don't beep twice - nil) - (t - (beep) - (message "please make a choice from the menu."))))))) - -;;; Categories: -;; -;; XEmacs use inheritable extents for the same purpose as Emacs uses -;; the category text property. - -(if (string-match "XEmacs" emacs-version) - (progn - ;; XEmacs categories. - (defun custom-category-create (name) - (set name (make-extent nil nil)) - "Create a text property category named NAME.") - - (defun custom-category-put (name property value) - "In CATEGORY set PROPERTY to VALUE." - (set-extent-property (symbol-value name) property value)) - - (defun custom-category-get (name property) - "In CATEGORY get PROPERTY." - (extent-property (symbol-value name) property)) - - (defun custom-category-set (from to category) - "Make text between FROM and TWO have category CATEGORY." - (let ((extent (make-extent from to))) - (set-extent-parent extent (symbol-value category))))) - - ;; Emacs categories. - (defun custom-category-create (name) - "Create a text property category named NAME." - (set name name)) - - (defun custom-category-put (name property value) - "In CATEGORY set PROPERTY to VALUE." - (put name property value)) - - (defun custom-category-get (name property) - "In CATEGORY get PROPERTY." - (get name property)) - - (defun custom-category-set (from to category) - "Make text between FROM and TWO have category CATEGORY." - (custom-put-text-property from to 'category category))) - -;;; External Data: -;; -;; The following functions and variables defines the interface for -;; connecting a CUSTOM with an external entity, by default an emacs -;; lisp variable. - -(defvar custom-external 'default-value - "Function returning the external value of NAME.") - -(defvar custom-external-set 'set-default - "Function setting the external value of NAME to VALUE.") - -(defun custom-external (name) - "Get the external value associated with NAME." - (funcall custom-external name)) - -(defun custom-external-set (name value) - "Set the external value associated with NAME to VALUE." - (funcall custom-external-set name value)) - -(defvar custom-name-fields nil - "Alist of custom names and their associated editing field.") -(make-variable-buffer-local 'custom-name-fields) - -(defun custom-name-enter (name field) - "Associate NAME with FIELD." - (if (null name) - () - (custom-assert 'field) - (setq custom-name-fields (cons (cons name field) custom-name-fields)))) - -(defun custom-name-field (name) - "The editing field associated with NAME." - (cdr (assq name custom-name-fields))) - -(defun custom-name-value (name) - "The value currently displayed for NAME in the customization buffer." - (let* ((field (custom-name-field name)) - (custom (custom-field-custom field))) - (custom-field-parse field) - (funcall (custom-property custom 'export) custom - (car (custom-field-extract custom field))))) - -(defvar custom-save 'custom-save - "Function that will save current customization buffer.") - -;;; Custom Functions: -;; -;; The following functions are part of the public interface to the -;; CUSTOM datastructure. Each CUSTOM describes a group of variables, -;; a single variable, or a component of a structured variable. The -;; CUSTOM instances are part of two hierarchies, the first is the -;; `part-of' hierarchy in which each CUSTOM is a component of another -;; CUSTOM, except for the top level CUSTOM which is contained in -;; `custom-data'. The second hierarchy is a `is-a' type hierarchy -;; where each CUSTOM is a leaf in the hierarchy defined by the `type' -;; property and `custom-type-properties'. - -(defvar custom-file "~/.custom.el" - "Name of file with customization information.") - -(defconst custom-data - '((tag . "Emacs") - (doc . "The extensible self-documenting text editor.") - (type . group) - (data "\n" - ((header . nil) - (compact . t) - (type . group) - (doc . "\ -Press [Save] to save any changes permanently after you are done editing. -You can load customization information from other files by editing the -`File' field and pressing the [Load] button. When you press [Save] the -customization information of all files you have loaded, plus any -changes you might have made manually, will be stored in the file -specified by the `File' field.") - (data ((tag . "Load") - (type . button) - (query . custom-load)) - ((tag . "Save") - (type . button) - (query . custom-save)) - ((name . custom-file) - (default . "~/.custom.el") - (doc . "Name of file with customization information.\n") - (tag . "File") - (type . file)))))) - "The global customization information. -A custom association list.") - -(defun custom-declare (path custom) - "Declare variables for customization. -PATH is a list of tags leading to the place in the customization -hierarchy the new entry should be added. CUSTOM is the entry to add." - (custom-initialize custom) - (let ((current (custom-travel-path custom-data path))) - (or (member custom (custom-data current)) - (nconc (custom-data current) (list custom))))) - -(put 'custom-declare 'lisp-indent-hook 1) - -(defconst custom-type-properties - '((repeat (type . default) - ;; See `custom-match'. - (import . custom-repeat-import) - (eval . custom-repeat-eval) - (quote . custom-repeat-quote) - (accept . custom-repeat-accept) - (extract . custom-repeat-extract) - (validate . custom-repeat-validate) - (insert . custom-repeat-insert) - (match . custom-repeat-match) - (query . custom-repeat-query) - (prefix . "") - (del-tag . "[DEL]") - (add-tag . "[INS]")) - (pair (type . group) - ;; A cons-cell. - (accept . custom-pair-accept) - (eval . custom-pair-eval) - (import . custom-pair-import) - (quote . custom-pair-quote) - (valid . (lambda (c d) (consp d))) - (extract . custom-pair-extract)) - (list (type . group) - ;; A lisp list. - (quote . custom-list-quote) - (valid . (lambda (c d) - (listp d))) - (extract . custom-list-extract)) - (group (type . default) - ;; See `custom-match'. - (face-tag . nil) - (eval . custom-group-eval) - (import . custom-group-import) - (initialize . custom-group-initialize) - (apply . custom-group-apply) - (reset . custom-group-reset) - (factory-reset . custom-group-factory-reset) - (extract . nil) - (validate . custom-group-validate) - (query . custom-toggle-hide) - (accept . custom-group-accept) - (insert . custom-group-insert) - (find . custom-group-find)) - (toggle (type . choice) - ;; Booleans. - (data ((type . const) - (tag . "On ") - (default . t)) - ((type . const) - (tag . "Off") - (default . nil)))) - (triggle (type . choice) - ;; On/Off/Default. - (data ((type . const) - (tag . "On ") - (default . t)) - ((type . const) - (tag . "Off") - (default . nil)) - ((type . const) - (tag . "Def") - (default . custom:asis)))) - (choice (type . default) - ;; See `custom-match'. - (query . custom-choice-query) - (accept . custom-choice-accept) - (extract . custom-choice-extract) - (validate . custom-choice-validate) - (insert . custom-choice-insert) - (none (tag . "Unknown") - (default . __uninitialized__) - (type . const))) - (const (type . default) - ;; A `const' only matches a single lisp value. - (extract . (lambda (c f) (list (custom-default c)))) - (validate . (lambda (c f) nil)) - (valid . custom-const-valid) - (update . custom-const-update) - (insert . custom-const-insert)) - (face-doc (type . doc) - ;; A variable containing a face. - (doc . "\ -You can customize the look of Emacs by deciding which faces should be -used when. If you push one of the face buttons below, you will be -given a choice between a number of standard faces. The name of the -selected face is shown right after the face button, and it is -displayed its own face so you can see how it looks. If you know of -another standard face not listed and want to use it, you can select -`Other' and write the name in the editing field. - -If none of the standard faces suits you, you can select `Customize' to -create your own face. This will make six fields appear under the face -button. The `Fg' and `Bg' fields are the foreground and background -colors for the face, respectively. You should type the name of the -color in the field. You can use any X11 color name. A list of X11 -color names may be available in the file `/usr/lib/X11/rgb.txt' on -your system. The special color name `default' means that the face -will not change the color of the text. The `Stipple' field is weird, -so just ignore it. The three remaining fields are toggles, which will -make the text `bold', `italic', or `underline' respectively. For some -fonts `bold' or `italic' will not make any visible change.")) - (face (type . choice) - (eval . custom-face-eval) - (import . custom-face-import) - (data ((tag . "None") - (default . nil) - (type . const)) - ((tag . "Default") - (default . default) - (face . custom-const-face) - (type . const)) - ((tag . "Bold") - (default . bold) - (face . custom-const-face) - (type . const)) - ((tag . "Bold-italic") - (default . bold-italic) - (face . custom-const-face) - (type . const)) - ((tag . "Italic") - (default . italic) - (face . custom-const-face) - (type . const)) - ((tag . "Underline") - (default . underline) - (face . custom-const-face) - (type . const)) - ((tag . "Highlight") - (default . highlight) - (face . custom-const-face) - (type . const)) - ((tag . "Modeline") - (default . modeline) - (face . custom-const-face) - (type . const)) - ((tag . "Region") - (default . region) - (face . custom-const-face) - (type . const)) - ((tag . "Secondary Selection") - (default . secondary-selection) - (face . custom-const-face) - (type . const)) - ((tag . "Customized") - (compact . t) - (face-tag . custom-face-hack) - (eval . custom-face-eval) - (data ((hidden . t) - (tag . "") - (doc . "\ -Select the properties you want this face to have.") - (default . custom-face-lookup) - (type . const)) - "\n" - ((tag . "Fg") - (hidden . t) - (default . "default") - (width . 20) - (type . string)) - ((tag . "Bg") - (default . "default") - (width . 20) - (type . string)) - ((tag . "Stipple") - (default . "default") - (width . 20) - (type . string)) - "\n" - ((tag . "Bold") - (default . custom:asis) - (type . triggle)) - " " - ((tag . "Italic") - (default . custom:asis) - (type . triggle)) - " " - ((tag . "Underline") - (hidden . t) - (default . custom:asis) - (type . triggle))) - (default . (custom-face-lookup "default" "default" "default" - nil nil nil)) - (type . list)) - ((prompt . "Other") - (face . custom-field-value) - (default . __uninitialized__) - (type . symbol)))) - (file (type . string) - ;; A string containing a file or directory name. - (directory . nil) - (default-file . nil) - (query . custom-file-query)) - (sexp (type . default) - ;; Any lisp expression. - (width . 40) - (default . (__uninitialized__ . "Uninitialized")) - (read . custom-sexp-read) - (write . custom-sexp-write)) - (symbol (type . sexp) - ;; A lisp symbol. - (width . 40) - (valid . (lambda (c d) (symbolp d)))) - (integer (type . sexp) - ;; A lisp integer. - (width . 10) - (valid . (lambda (c d) (integerp d)))) - (string (type . default) - ;; A lisp string. - (width . 40) - (valid . (lambda (c d) (stringp d))) - (read . custom-string-read) - (write . custom-string-write)) - (button (type . default) - ;; Push me. - (accept . ignore) - (extract . nil) - (validate . ignore) - (insert . custom-button-insert)) - (doc (type . default) - ;; A documentation only entry with no value. - (header . nil) - (reset . ignore) - (extract . nil) - (validate . ignore) - (insert . custom-documentation-insert)) - (default (width . 20) - (valid . (lambda (c v) t)) - (insert . custom-default-insert) - (update . custom-default-update) - (query . custom-default-query) - (tag . nil) - (prompt . nil) - (doc . nil) - (header . t) - (padding . ? ) - (quote . custom-default-quote) - (eval . (lambda (c v) nil)) - (export . custom-default-export) - (import . (lambda (c v) (list v))) - (synchronize . ignore) - (initialize . custom-default-initialize) - (extract . custom-default-extract) - (validate . custom-default-validate) - (apply . custom-default-apply) - (reset . custom-default-reset) - (factory-reset . custom-default-factory-reset) - (accept . custom-default-accept) - (match . custom-default-match) - (name . nil) - (compact . nil) - (hidden . nil) - (face . custom-default-face) - (data . nil) - (calculate . nil) - (default . __uninitialized__))) - "Alist of default properties for type symbols. -The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.") - -(defconst custom-local-type-properties nil - "Local type properties. -Entries in this list take precedence over `custom-type-properties'.") - -(make-variable-buffer-local 'custom-local-type-properties) - -(defconst custom-nil '__uninitialized__ - "Special value representing an uninitialized field.") - -(defconst custom-invalid '__invalid__ - "Special value representing an invalid field.") - -(defconst custom:asis 'custom:asis) -;; Bad, ugly, and horrible kludge. - -(defun custom-property (custom property) - "Extract from CUSTOM property PROPERTY." - (let ((entry (assq property custom))) - (while (null entry) - ;; Look in superclass. - (let ((type (custom-type custom))) - (setq custom (cdr (or (assq type custom-local-type-properties) - (assq type custom-type-properties))) - entry (assq property custom)) - (custom-assert 'custom))) - (cdr entry))) - -(defun custom-super (custom property) - "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass." - (let ((entry nil)) - (while (null entry) - ;; Look in superclass. - (let ((type (custom-type custom))) - (setq custom (cdr (or (assq type custom-local-type-properties) - (assq type custom-type-properties))) - entry (assq property custom)) - (custom-assert 'custom))) - (cdr entry))) - -(defun custom-property-set (custom property value) - "Set CUSTOM PROPERTY to VALUE by side effect. -CUSTOM must have at least one property already." - (let ((entry (assq property custom))) - (if entry - (setcdr entry value) - (setcdr custom (cons (cons property value) (cdr custom)))))) - -(defun custom-type (custom) - "Extract `type' from CUSTOM." - (cdr (assq 'type custom))) - -(defun custom-name (custom) - "Extract `name' from CUSTOM." - (custom-property custom 'name)) - -(defun custom-tag (custom) - "Extract `tag' from CUSTOM." - (custom-property custom 'tag)) - -(defun custom-face-tag (custom) - "Extract `face-tag' from CUSTOM." - (custom-property custom 'face-tag)) - -(defun custom-prompt (custom) - "Extract `prompt' from CUSTOM. -If none exist, default to `tag' or, failing that, `type'." - (or (custom-property custom 'prompt) - (custom-property custom 'tag) - (capitalize (symbol-name (custom-type custom))))) - -(defun custom-default (custom) - "Extract `default' from CUSTOM." - (let ((value (custom-property custom 'calculate))) - (if value - (eval value) - (custom-property custom 'default)))) - -(defun custom-data (custom) - "Extract the `data' from CUSTOM." - (custom-property custom 'data)) - -(defun custom-documentation (custom) - "Extract `doc' from CUSTOM." - (custom-property custom 'doc)) - -(defun custom-width (custom) - "Extract `width' from CUSTOM." - (custom-property custom 'width)) - -(defun custom-compact (custom) - "Extract `compact' from CUSTOM." - (custom-property custom 'compact)) - -(defun custom-padding (custom) - "Extract `padding' from CUSTOM." - (custom-property custom 'padding)) - -(defun custom-valid (custom value) - "Non-nil if CUSTOM may validly be set to VALUE." - (and (not (and (listp value) (eq custom-invalid (car value)))) - (funcall (custom-property custom 'valid) custom value))) - -(defun custom-import (custom value) - "Import CUSTOM VALUE from external variable. - -This function change VALUE into a form that makes it easier to edit -internally. What the internal form is exactly depends on CUSTOM. -The internal form is returned." - (if (eq custom-nil value) - (list custom-nil) - (funcall (custom-property custom 'import) custom value))) - -(defun custom-eval (custom value) - "Return non-nil if CUSTOM's VALUE needs to be evaluated." - (funcall (custom-property custom 'eval) custom value)) - -(defun custom-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (funcall (custom-property custom 'quote) custom value)) - -(defun custom-write (custom value) - "Convert CUSTOM VALUE to a string." - (cond ((eq value custom-nil) - "") - ((and (listp value) (eq (car value) custom-invalid)) - (cdr value)) - (t - (funcall (custom-property custom 'write) custom value)))) - -(defun custom-read (custom string) - "Convert CUSTOM field content STRING into lisp." - (condition-case nil - (funcall (custom-property custom 'read) custom string) - (error (cons custom-invalid string)))) - -(defun custom-match (custom values) - "Match CUSTOM with a list of VALUES. - -Return a cons-cell where the car is the sublist of VALUES matching CUSTOM, -and the cdr is the remaining VALUES. - -A CUSTOM is actually a regular expression over the alphabet of lisp -types. Most CUSTOM types are just doing a literal match, e.g. the -`symbol' type matches any lisp symbol. The exceptions are: - -group: which corresponds to a `(' and `)' group in a regular expression. -choice: which corresponds to a group of `|' in a regular expression. -repeat: which corresponds to a `*' in a regular expression. -optional: which corresponds to a `?', and isn't implemented yet." - (if (memq values (list custom-nil nil)) - ;; Nothing matches the uninitialized or empty list. - (cons custom-nil nil) - (funcall (custom-property custom 'match) custom values))) - -(defun custom-initialize (custom) - "Initialize `doc' and `default' attributes of CUSTOM." - (funcall (custom-property custom 'initialize) custom)) - -(defun custom-find (custom tag) - "Find child in CUSTOM with `tag' TAG." - (funcall (custom-property custom 'find) custom tag)) - -(defun custom-travel-path (custom path) - "Find decedent of CUSTOM by looking through PATH." - (if (null path) - custom - (custom-travel-path (custom-find custom (car path)) (cdr path)))) - -(defun custom-field-extract (custom field) - "Extract CUSTOM's value in FIELD." - (if (stringp custom) - nil - (funcall (custom-property (custom-field-custom field) 'extract) - custom field))) - -(defun custom-field-validate (custom field) - "Validate CUSTOM's value in FIELD. -Return nil if valid, otherwise return a cons-cell where the car is the -position of the error, and the cdr is a text describing the error." - (if (stringp custom) - nil - (funcall (custom-property custom 'validate) custom field))) - -;;; Field Functions: -;; -;; This section defines the public functions for manipulating the -;; FIELD datatype. The FIELD instance hold information about a -;; specific editing field in the customization buffer. -;; -;; Each FIELD can be seen as an instantiation of a CUSTOM. - -(defvar custom-field-last nil) -;; Last field containing point. -(make-variable-buffer-local 'custom-field-last) - -(defvar custom-modified-list nil) -;; List of modified fields. -(make-variable-buffer-local 'custom-modified-list) - -(defun custom-field-create (custom value) - "Create a field structure of type CUSTOM containing VALUE. - -A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where -CUSTOM defines the type of the field, -VALUE is the current value of the field, -ORIGINAL is the original value when created, and -START and END are markers to the start and end of the field." - (vector custom value custom-nil nil nil)) - -(defun custom-field-custom (field) - "Return the `custom' attribute of FIELD." - (aref field 0)) - -(defun custom-field-value (field) - "Return the `value' attribute of FIELD." - (aref field 1)) - -(defun custom-field-original (field) - "Return the `original' attribute of FIELD." - (aref field 2)) - -(defun custom-field-start (field) - "Return the `start' attribute of FIELD." - (aref field 3)) - -(defun custom-field-end (field) - "Return the `end' attribute of FIELD." - (aref field 4)) - -(defun custom-field-value-set (field value) - "Set the `value' attribute of FIELD to VALUE." - (aset field 1 value)) - -(defun custom-field-original-set (field original) - "Set the `original' attribute of FIELD to ORIGINAL." - (aset field 2 original)) - -(defun custom-field-move (field start end) - "Set the `start'and `end' attributes of FIELD to START and END." - (set-marker (or (aref field 3) (aset field 3 (make-marker))) start) - (set-marker (or (aref field 4) (aset field 4 (make-marker))) end)) - -(defun custom-field-query (field) - "Query user for content of current field." - (funcall (custom-property (custom-field-custom field) 'query) field)) - -(defun custom-field-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE. -If optional ORIGINAL is non-nil, consider VALUE for the original value." - (let ((inhibit-point-motion-hooks t)) - (funcall (custom-property (custom-field-custom field) 'accept) - field value original))) - -(defun custom-field-face (field) - "The face used for highlighting FIELD." - (let ((custom (custom-field-custom field))) - (if (stringp custom) - nil - (let ((face (funcall (custom-property custom 'face) field))) - (if (custom-facep face) face nil))))) - -(defun custom-field-update (field) - "Update the screen appearance of FIELD to correspond with the field's value." - (let ((custom (custom-field-custom field))) - (if (stringp custom) - nil - (funcall (custom-property custom 'update) field)))) - -;;; Types: -;; -;; The following functions defines type specific actions. - -(defun custom-repeat-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (if (eq value custom-nil) - nil - (let ((child (custom-data custom)) - (found nil)) - (mapcar (lambda (v) (if (custom-eval child v) (setq found t))) - value)))) - -(defun custom-repeat-quote (custom value) - "A list of CUSTOM's VALUEs quoted." - (let ((child (custom-data custom))) - (apply 'append (mapcar (lambda (v) (custom-quote child v)) - value)))) - - -(defun custom-repeat-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((child (custom-data custom))) - (apply 'append (mapcar (lambda (v) (custom-import child v)) - value)))) - -(defun custom-repeat-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let ((values (copy-sequence (custom-field-value field))) - (all (custom-field-value field)) - (start (custom-field-start field)) - current new) - (if original - (custom-field-original-set field value)) - (while (consp value) - (setq new (car value) - value (cdr value)) - (if values - ;; Change existing field. - (setq current (car values) - values (cdr values)) - ;; Insert new field if series has grown. - (goto-char start) - (setq current (custom-repeat-insert-entry field)) - (setq all (custom-insert-before all nil current)) - (custom-field-value-set field all)) - (custom-field-accept current new original)) - (while (consp values) - ;; Delete old field if series has scrunk. - (setq current (car values) - values (cdr values)) - (let ((pos (custom-field-start current)) - data) - (while (not data) - (setq pos (previous-single-property-change pos 'custom-data)) - (custom-assert 'pos) - (setq data (get-text-property pos 'custom-data)) - (or (and (arrayp data) - (> (length data) 1) - (eq current (aref data 1))) - (setq data nil))) - (custom-repeat-delete data))))) - -(defun custom-repeat-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - (add-tag (custom-property custom 'add-tag)) - (start (make-marker)) - (data (vector field nil start nil))) - (custom-text-insert "\n") - (let ((pos (point))) - (custom-text-insert (custom-property custom 'prefix)) - (custom-tag-insert add-tag 'custom-repeat-add data) - (set-marker start pos)) - (custom-field-move field start (point)) - (custom-documentation-insert custom) - field)) - -(defun custom-repeat-insert-entry (repeat) - "Insert entry at point in the REPEAT field." - (let* ((inhibit-point-motion-hooks t) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - (custom (custom-field-custom repeat)) - (add-tag (custom-property custom 'add-tag)) - (del-tag (custom-property custom 'del-tag)) - (start (make-marker)) - (end (make-marker)) - (data (vector repeat nil start end)) - field) - (custom-extent-start-open) - (insert-before-markers "\n") - (backward-char 1) - (set-marker start (point)) - (custom-text-insert " ") - (aset data 1 (setq field (custom-insert (custom-data custom) nil))) - (custom-text-insert " ") - (set-marker end (point)) - (goto-char start) - (custom-text-insert (custom-property custom 'prefix)) - (custom-tag-insert add-tag 'custom-repeat-add data) - (custom-text-insert " ") - (custom-tag-insert del-tag 'custom-repeat-delete data) - (forward-char 1) - field)) - -(defun custom-repeat-add (data) - "Add list entry." - (let ((parent (aref data 0)) - (field (aref data 1)) - (at (aref data 2)) - new) - (goto-char at) - (setq new (custom-repeat-insert-entry parent)) - (custom-field-value-set parent - (custom-insert-before (custom-field-value parent) - field new)))) - -(defun custom-repeat-delete (data) - "Delete list entry." - (let ((inhibit-point-motion-hooks t) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - (parent (aref data 0)) - (field (aref data 1))) - (delete-region (aref data 2) (1+ (aref data 3))) - (custom-field-untouch (aref data 1)) - (custom-field-value-set parent - (delq field (custom-field-value parent))))) - -(defun custom-repeat-match (custom values) - "Match CUSTOM with VALUES." - (let* ((child (custom-data custom)) - (match (custom-match child values)) - matches) - (while (not (eq (car match) custom-nil)) - (setq matches (cons (car match) matches) - values (cdr match) - match (custom-match child values))) - (cons (nreverse matches) values))) - -(defun custom-repeat-extract (custom field) - "Extract list of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - () - (while values - (setq result (append result (custom-field-extract data (car values))) - values (cdr values)))) - result)) - -(defun custom-repeat-validate (custom field) - "Validate children." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - (setq result (cons (custom-field-start field) "Uninitialized list"))) - (while (and values (not result)) - (setq result (custom-field-validate data (car values)) - values (cdr values))) - result)) - -(defun custom-pair-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (custom-group-accept field (list (car value) (cdr value)) original)) - -(defun custom-pair-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (custom-group-eval custom (list (car value) (cdr value)))) - -(defun custom-pair-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((result (car (custom-group-import custom - (list (car value) (cdr value)))))) - (custom-assert '(eq (length result) 2)) - (list (cons (nth 0 result) (nth 1 result))))) - -(defun custom-pair-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (if (custom-eval custom value) - (let ((v (car (custom-group-quote custom - (list (car value) (cdr value)))))) - (list (list 'cons (nth 0 v) (nth 1 v)))) - (custom-default-quote custom value))) - -(defun custom-pair-extract (custom field) - "Extract cons of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (custom-assert '(eq (length values) (length data))) - (while values - (setq result (append result - (custom-field-extract (car data) (car values))) - data (cdr data) - values (cdr values))) - (custom-assert '(null data)) - (list (cons (nth 0 result) (nth 1 result))))) - -(defun custom-list-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (if (custom-eval custom value) - (let ((v (car (custom-group-quote custom value)))) - (list (cons 'list v))) - (custom-default-quote custom value))) - -(defun custom-list-extract (custom field) - "Extract list of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (custom-assert '(eq (length values) (length data))) - (while values - (setq result (append result - (custom-field-extract (car data) (car values))) - data (cdr data) - values (cdr values))) - (custom-assert '(null data)) - (list result))) - -(defun custom-group-validate (custom field) - "Validate children." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - (setq result (cons (custom-field-start field) "Uninitialized list")) - (custom-assert '(eq (length values) (length data)))) - (while (and values (not result)) - (setq result (custom-field-validate (car data) (car values)) - data (cdr data) - values (cdr values))) - result)) - -(defun custom-group-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (let ((found nil)) - (mapcar (lambda (c) - (or (stringp c) - (let ((match (custom-match c value))) - (if (custom-eval c (car match)) - (setq found t)) - (setq value (cdr match))))) - (custom-data custom)) - found)) - -(defun custom-group-quote (custom value) - "A list of CUSTOM's VALUE members, quoted." - (list (apply 'append - (mapcar (lambda (c) - (if (stringp c) - () - (let ((match (custom-match c value))) - (prog1 (custom-quote c (car match)) - (setq value (cdr match)))))) - (custom-data custom))))) - -(defun custom-group-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (list (apply 'append - (mapcar (lambda (c) - (if (stringp c) - () - (let ((match (custom-match c value))) - (prog1 (custom-import c (car match)) - (setq value (cdr match)))))) - (custom-data custom))))) - -(defun custom-group-initialize (custom) - "Initialize `doc' and `default' entries in CUSTOM." - (if (custom-name custom) - (custom-default-initialize custom) - (mapcar 'custom-initialize (custom-data custom)))) - -(defun custom-group-apply (field) - "Reset `value' in FIELD to `original'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-apply field) - (mapcar 'custom-field-apply values)))) - -(defun custom-group-reset (field) - "Reset `value' in FIELD to `original'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-reset field) - (mapcar 'custom-field-reset values)))) - -(defun custom-group-factory-reset (field) - "Reset `value' in FIELD to `default'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-factory-reset field) - (mapcar 'custom-field-factory-reset values)))) - -(defun custom-group-find (custom tag) - "Find child in CUSTOM with `tag' TAG." - (let ((data (custom-data custom)) - (result nil)) - (while (not result) - (custom-assert 'data) - (if (equal (custom-tag (car data)) tag) - (setq result (car data)) - (setq data (cdr data)))))) - -(defun custom-group-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let* ((values (custom-field-value field)) - (custom (custom-field-custom field)) - (from (custom-field-start field)) - (face-tag (custom-face-tag custom)) - current) - (if face-tag - (custom-put-text-property from (+ from (length (custom-tag custom))) - 'face (funcall face-tag field value))) - (if original - (custom-field-original-set field value)) - (while values - (setq current (car values) - values (cdr values)) - (if current - (let* ((custom (custom-field-custom current)) - (match (custom-match custom value))) - (setq value (cdr match)) - (custom-field-accept current (car match) original)))))) - -(defun custom-group-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - fields hidden - (from (point)) - (compact (custom-compact custom)) - (tag (custom-tag custom)) - (face-tag (custom-face-tag custom))) - (cond (face-tag (custom-text-insert tag)) - (tag (custom-tag-insert tag field))) - (or compact (custom-documentation-insert custom)) - (or compact (custom-text-insert "\n")) - (let ((data (custom-data custom))) - (while data - (setq fields (cons (custom-insert (car data) (if level (1+ level))) - fields)) - (setq hidden (or (stringp (car data)) - (custom-property (car data) 'hidden))) - (setq data (cdr data)) - (if data (custom-text-insert (cond (hidden "") - (compact " ") - (t "\n")))))) - (if compact (custom-documentation-insert custom)) - (custom-field-value-set field (nreverse fields)) - (custom-field-move field from (point)) - field)) - -(defun custom-choice-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - (from (point))) - (custom-text-insert "lars er en nisse") - (custom-field-move field from (point)) - (custom-documentation-insert custom) - (custom-field-reset field) - field)) - -(defun custom-choice-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let ((custom (custom-field-custom field)) - (start (custom-field-start field)) - (end (custom-field-end field)) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - from) - (cond (original - (setq custom-modified-list (delq field custom-modified-list)) - (custom-field-original-set field value)) - ((equal value (custom-field-original field)) - (setq custom-modified-list (delq field custom-modified-list))) - (t - (add-to-list 'custom-modified-list field))) - (custom-field-untouch (custom-field-value field)) - (delete-region start end) - (goto-char start) - (setq from (point)) - (insert-before-markers " ") - (backward-char 1) - (custom-category-set (point) (1+ (point)) 'custom-hidden-properties) - (custom-tag-insert (custom-tag custom) field) - (custom-text-insert ": ") - (let ((data (custom-data custom)) - found begin) - (while (and data (not found)) - (if (not (custom-valid (car data) value)) - (setq data (cdr data)) - (setq found (custom-insert (car data) nil)) - (setq data nil))) - (if found - () - (setq begin (point) - found (custom-insert (custom-property custom 'none) nil)) - (custom-add-text-properties - begin (point) - (list rear-nonsticky t - 'face custom-field-uninitialized-face))) - (or original - (custom-field-original-set found (custom-field-original field))) - (custom-field-accept found value original) - (custom-field-value-set field found) - (custom-field-move field from end)))) - -(defun custom-choice-extract (custom field) - "Extract child's value." - (let ((value (custom-field-value field))) - (custom-field-extract (custom-field-custom value) value))) - -(defun custom-choice-validate (custom field) - "Validate child's value." - (let ((value (custom-field-value field)) - (custom (custom-field-custom field))) - (if (or (eq value custom-nil) - (eq (custom-field-custom value) (custom-property custom 'none))) - (cons (custom-field-start field) "Make a choice") - (custom-field-validate (custom-field-custom value) value)))) - -(defun custom-choice-query (field) - "Choose a child." - (let* ((custom (custom-field-custom field)) - (old (custom-field-custom (custom-field-value field))) - (default (custom-prompt old)) - (tag (custom-prompt custom)) - (data (custom-data custom)) - current alist) - (if (eq (length data) 2) - (custom-field-accept field (custom-default (if (eq (nth 0 data) old) - (nth 1 data) - (nth 0 data)))) - (while data - (setq current (car data) - data (cdr data)) - (setq alist (cons (cons (custom-prompt current) current) alist))) - (let ((answer (cond ((and (fboundp 'button-press-event-p) - (fboundp 'popup-menu) - (button-press-event-p last-input-event)) - (cdr (assoc (car (custom-x-really-popup-menu - last-input-event tag - (reverse alist))) - alist))) - ((listp last-input-event) - (x-popup-menu last-input-event - (list tag (cons "" (reverse alist))))) - (t - (let ((choice (completing-read (concat tag - " (default " - default - "): ") - alist nil t))) - (if (or (null choice) (string-equal choice "")) - (setq choice default)) - (cdr (assoc choice alist))))))) - (if answer - (custom-field-accept field (custom-default answer))))))) - -(defun custom-file-query (field) - "Prompt for a file name" - (let* ((value (custom-field-value field)) - (custom (custom-field-custom field)) - (valid (custom-valid custom value)) - (directory (custom-property custom 'directory)) - (default (and (not valid) - (custom-property custom 'default-file))) - (tag (custom-tag custom)) - (prompt (if default - (concat tag " (" default "): ") - (concat tag ": ")))) - (custom-field-accept field - (if (custom-valid custom value) - (read-file-name prompt - (if (file-name-absolute-p value) - "" - directory) - default nil value) - (read-file-name prompt directory default))))) - -(defun custom-face-eval (custom value) - "Return non-nil if CUSTOM's VALUE needs to be evaluated." - (not (symbolp value))) - -(defun custom-face-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((name (or (and (facep value) (symbol-name (face-name value))) - (symbol-name value)))) - (list (if (string-match "\ -custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)" - name) - (list 'custom-face-lookup - (match-string 1 name) - (match-string 2 name) - (match-string 3 name) - (intern (match-string 4 name)) - (intern (match-string 5 name)) - (intern (match-string 6 name))) - value)))) - -(defun custom-face-lookup (&optional fg bg stipple bold italic underline) - "Lookup or create a face with specified attributes." - (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" - (or fg "default") - (or bg "default") - (or stipple "default") - bold italic underline)))) - (if (and (custom-facep name) - (fboundp 'make-face)) - () - (copy-face 'default name) - (when (and fg - (not (string-equal fg "default"))) - (condition-case () - (set-face-foreground name fg) - (error nil))) - (when (and bg - (not (string-equal bg "default"))) - (condition-case () - (set-face-background name bg) - (error nil))) - (when (and stipple - (not (string-equal stipple "default")) - (not (eq stipple 'custom:asis)) - (fboundp 'set-face-stipple)) - (set-face-stipple name stipple)) - (when (and bold - (not (eq bold 'custom:asis))) - (condition-case () - (make-face-bold name) - (error nil))) - (when (and italic - (not (eq italic 'custom:asis))) - (condition-case () - (make-face-italic name) - (error nil))) - (when (and underline - (not (eq underline 'custom:asis))) - (condition-case () - (set-face-underline-p name t) - (error nil)))) - name)) - -(defun custom-face-hack (field value) - "Face that should be used for highlighting FIELD containing VALUE." - (let* ((custom (custom-field-custom field)) - (form (funcall (custom-property custom 'export) custom value)) - (face (apply (car form) (cdr form)))) - (if (custom-facep face) face nil))) - -(defun custom-const-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom custom-nil)) - (face (custom-field-face field)) - (from (point))) - (custom-text-insert (custom-tag custom)) - (custom-add-text-properties from (point) - (list 'face face - rear-nonsticky t)) - (custom-documentation-insert custom) - (custom-field-move field from (point)) - field)) - -(defun custom-const-update (field) - "Update face of FIELD." - (let ((from (custom-field-start field)) - (custom (custom-field-custom field))) - (custom-put-text-property from (+ from (length (custom-tag custom))) - 'face (custom-field-face field)))) - -(defun custom-const-valid (custom value) - "Non-nil if CUSTOM can validly have the value VALUE." - (equal (custom-default custom) value)) - -(defun custom-const-face (field) - "Face used for a FIELD." - (custom-default (custom-field-custom field))) - -(defun custom-sexp-read (custom string) - "Read from CUSTOM an STRING." - (save-match-data - (save-excursion - (set-buffer (get-buffer-create " *Custom Scratch*")) - (erase-buffer) - (insert string) - (goto-char (point-min)) - (prog1 (read (current-buffer)) - (or (looking-at - (concat (regexp-quote (char-to-string - (custom-padding custom))) - "*\\'")) - (error "Junk at end of expression")))))) - -(autoload 'pp-to-string "pp") - -(defun custom-sexp-write (custom sexp) - "Write CUSTOM SEXP as string." - (let ((string (prin1-to-string sexp))) - (if (<= (length string) (custom-width custom)) - string - (setq string (pp-to-string sexp)) - (string-match "[ \t\n]*\\'" string) - (concat "\n" (substring string 0 (match-beginning 0)))))) - -(defun custom-string-read (custom string) - "Read string by ignoring trailing padding characters." - (let ((last (length string)) - (padding (custom-padding custom))) - (while (and (> last 0) - (eq (aref string (1- last)) padding)) - (setq last (1- last))) - (substring string 0 last))) - -(defun custom-string-write (custom string) - "Write raw string." - string) - -(defun custom-button-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (custom-tag-insert (concat "[" (custom-tag custom) "]") - (custom-property custom 'query)) - (custom-documentation-insert custom) - nil) - -(defun custom-default-export (custom value) - ;; Convert CUSTOM's VALUE to external representation. - ;; See `custom-import'. - (if (custom-eval custom value) - (eval (car (custom-quote custom value))) - value)) - -(defun custom-default-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (list (if (and (not (custom-eval custom value)) - (or (and (symbolp value) - value - (not (eq t value))) - (and (listp value) - value - (not (memq (car value) '(quote function lambda)))))) - (list 'quote value) - value))) - -(defun custom-default-initialize (custom) - "Initialize `doc' and `default' entries in CUSTOM." - (let ((name (custom-name custom))) - (if (null name) - () - (let ((default (custom-default custom)) - (doc (custom-documentation custom)) - (vdoc (documentation-property name 'variable-documentation t))) - (if doc - (or vdoc (put name 'variable-documentation doc)) - (if vdoc (custom-property-set custom 'doc vdoc))) - (if (eq default custom-nil) - (if (boundp name) - (custom-property-set custom 'default (symbol-value name))) - (or (boundp name) - (set name default))))))) - -(defun custom-default-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let ((field (custom-field-create custom custom-nil)) - (tag (custom-tag custom))) - (if (null tag) - () - (custom-tag-insert tag field) - (custom-text-insert ": ")) - (custom-field-insert field) - (custom-documentation-insert custom) - field)) - -(defun custom-default-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (if original - (custom-field-original-set field value)) - (custom-field-value-set field value) - (custom-field-update field)) - -(defun custom-default-apply (field) - "Apply any changes in FIELD since the last apply." - (let* ((custom (custom-field-custom field)) - (name (custom-name custom))) - (if (null name) - (error "This field cannot be applied alone")) - (custom-external-set name (custom-name-value name)) - (custom-field-reset field))) - -(defun custom-default-reset (field) - "Reset content of editing FIELD to `original'." - (custom-field-accept field (custom-field-original field) t)) - -(defun custom-default-factory-reset (field) - "Reset content of editing FIELD to `default'." - (let* ((custom (custom-field-custom field)) - (default (car (custom-import custom (custom-default custom))))) - (or (eq default custom-nil) - (custom-field-accept field default nil)))) - -(defun custom-default-query (field) - "Prompt for a FIELD" - (let* ((custom (custom-field-custom field)) - (value (custom-field-value field)) - (initial (custom-write custom value)) - (prompt (concat (custom-prompt custom) ": "))) - (custom-field-accept field - (custom-read custom - (if (custom-valid custom value) - (read-string prompt (cons initial 1)) - (read-string prompt)))))) - -(defun custom-default-match (custom values) - "Match CUSTOM with VALUES." - values) - -(defun custom-default-extract (custom field) - "Extract CUSTOM's content in FIELD." - (list (custom-field-value field))) - -(defun custom-default-validate (custom field) - "Validate FIELD." - (let ((value (custom-field-value field)) - (start (custom-field-start field))) - (cond ((eq value custom-nil) - (cons start "Uninitialized field")) - ((and (consp value) (eq (car value) custom-invalid)) - (cons start "Unparsable field content")) - ((custom-valid custom value) - nil) - (t - (cons start "Wrong type of field content"))))) - -(defun custom-default-face (field) - "Face used for a FIELD." - (let ((value (custom-field-value field))) - (cond ((eq value custom-nil) - custom-field-uninitialized-face) - ((not (custom-valid (custom-field-custom field) value)) - custom-field-invalid-face) - ((not (equal (custom-field-original field) value)) - custom-field-modified-face) - (t - custom-field-face)))) - -(defun custom-default-update (field) - "Update the content of FIELD." - (let ((inhibit-point-motion-hooks t) - (before-change-functions nil) - (after-change-functions nil) - (start (custom-field-start field)) - (end (custom-field-end field)) - (pos (point))) - ;; Keep track of how many modified fields we have. - (cond ((equal (custom-field-value field) (custom-field-original field)) - (setq custom-modified-list (delq field custom-modified-list))) - ((memq field custom-modified-list)) - (t - (setq custom-modified-list (cons field custom-modified-list)))) - ;; Update the field. - (goto-char end) - (insert-before-markers " ") - (delete-region start (1- end)) - (goto-char start) - (custom-field-insert field) - (goto-char end) - (delete-char 1) - (goto-char pos) - (and (<= start pos) - (<= pos end) - (custom-field-enter field)))) - -;;; Create Buffer: -;; -;; Public functions to create a customization buffer and to insert -;; various forms of text, fields, and buttons in it. - -(defun customize () - "Customize GNU Emacs. -Create a *Customize* buffer with editable customization information -about GNU Emacs." - (interactive) - (custom-buffer-create "*Customize*") - (custom-reset-all)) - -(defun custom-buffer-create (name &optional custom types set get save) - "Create a customization buffer named NAME. -If the optional argument CUSTOM is non-nil, use that as the custom declaration. -If the optional argument TYPES is non-nil, use that as the local types. -If the optional argument SET is non-nil, use that to set external data. -If the optional argument GET is non-nil, use that to get external data. -If the optional argument SAVE is non-nil, use that for saving changes." - (switch-to-buffer name) - (buffer-disable-undo (current-buffer)) - (custom-mode) - (setq custom-local-type-properties types) - (if (null custom) - () - (make-local-variable 'custom-data) - (setq custom-data custom)) - (if (null set) - () - (make-local-variable 'custom-external-set) - (setq custom-external-set set)) - (if (null get) - () - (make-local-variable 'custom-external) - (setq custom-external get)) - (if (null save) - () - (make-local-variable 'custom-save) - (setq custom-save save)) - (let ((inhibit-point-motion-hooks t) - (before-change-functions nil) - (after-change-functions nil)) - (erase-buffer) - (insert "\n") - (goto-char (point-min)) - (custom-text-insert "This is a customization buffer.\n") - (custom-help-insert "\n") - (custom-help-button 'custom-forward-field) - (custom-help-button 'custom-backward-field) - (custom-help-button 'custom-enter-value) - (custom-help-button 'custom-field-factory-reset) - (custom-help-button 'custom-field-reset) - (custom-help-button 'custom-field-apply) - (custom-help-button 'custom-save-and-exit) - (custom-help-button 'custom-toggle-documentation) - (custom-help-insert "\nClick mouse-2 on any button to activate it.\n") - (custom-text-insert "\n") - (custom-insert custom-data 0) - (goto-char (point-min)))) - -(defun custom-insert (custom level) - "Insert custom declaration CUSTOM in current buffer at level LEVEL." - (if (stringp custom) - (progn - (custom-text-insert custom) - nil) - (and level (null (custom-property custom 'header)) - (setq level nil)) - (and level - (> level 0) - (custom-text-insert (concat "\n" (make-string level ?*) " "))) - (let ((field (funcall (custom-property custom 'insert) custom level))) - (custom-name-enter (custom-name custom) field) - field))) - -(defun custom-text-insert (text) - "Insert TEXT in current buffer." - (insert text)) - -(defun custom-tag-insert (tag field &optional data) - "Insert TAG for FIELD in current buffer." - (let ((from (point))) - (insert tag) - (custom-category-set from (point) 'custom-button-properties) - (custom-put-text-property from (point) 'custom-tag field) - (if data - (custom-add-text-properties from (point) (list 'custom-data data))))) - -(defun custom-documentation-insert (custom &rest ignore) - "Insert documentation from CUSTOM in current buffer." - (let ((doc (custom-documentation custom))) - (if (null doc) - () - (custom-help-insert "\n" doc)))) - -(defun custom-help-insert (&rest args) - "Insert ARGS as documentation text." - (let ((from (point))) - (apply 'insert args) - (custom-category-set from (point) 'custom-documentation-properties))) - -(defun custom-help-button (command) - "Describe how to execute COMMAND." - (let ((from (point))) - (insert "`" (key-description (where-is-internal command nil t)) "'") - (custom-set-text-properties from (point) - (list 'face custom-button-face - mouse-face custom-mouse-face - 'custom-jump t ;Make TAB jump over it. - 'custom-tag command - 'start-open t - 'end-open t)) - (custom-category-set from (point) 'custom-documentation-properties)) - (custom-help-insert ": " (custom-first-line (documentation command)) "\n")) - -;;; Mode: -;; -;; The Customization major mode and interactive commands. - -(defvar custom-mode-map nil - "Keymap for Custom Mode.") -(if custom-mode-map - nil - (setq custom-mode-map (make-sparse-keymap)) - (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button) - (define-key custom-mode-map "\t" 'custom-forward-field) - (define-key custom-mode-map "\M-\t" 'custom-backward-field) - (define-key custom-mode-map "\r" 'custom-enter-value) - (define-key custom-mode-map "\C-k" 'custom-kill-line) - (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset) - (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all) - (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset) - (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all) - (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply) - (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all) - (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit) - (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation)) - -;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f -;; forward-field, C-b backward-field, C-n next-field, C-p -;; previous-field, ? describe-field. - -(defun custom-mode () - "Major mode for doing customizations. - -\\{custom-mode-map}" - (kill-all-local-variables) - (setq major-mode 'custom-mode - mode-name "Custom") - (use-local-map custom-mode-map) - (make-local-variable 'before-change-functions) - (setq before-change-functions '(custom-before-change)) - (make-local-variable 'after-change-functions) - (setq after-change-functions '(custom-after-change)) - (if (not (fboundp 'make-local-hook)) - ;; Emacs 19.28 and earlier. - (add-hook 'post-command-hook - (lambda () - (if (eq major-mode 'custom-mode) - (custom-post-command)))) - ;; Emacs 19.29. - (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'custom-post-command nil t))) - -(defun custom-forward-field (arg) - "Move point to the next field or button. -With optional ARG, move across that many fields." - (interactive "p") - (while (> arg 0) - (let ((next (if (get-text-property (point) 'custom-tag) - (next-single-property-change (point) 'custom-tag) - (point)))) - (setq next (or (next-single-property-change next 'custom-tag) - (next-single-property-change (point-min) 'custom-tag))) - (if next - (goto-char next) - (error "No customization fields in this buffer."))) - (or (get-text-property (point) 'custom-jump) - (setq arg (1- arg)))) - (while (< arg 0) - (let ((previous (if (get-text-property (1- (point)) 'custom-tag) - (previous-single-property-change (point) 'custom-tag) - (point)))) - (setq previous - (or (previous-single-property-change previous 'custom-tag) - (previous-single-property-change (point-max) 'custom-tag))) - (if previous - (goto-char previous) - (error "No customization fields in this buffer."))) - (or (get-text-property (1- (point)) 'custom-jump) - (setq arg (1+ arg))))) - -(defun custom-backward-field (arg) - "Move point to the previous field or button. -With optional ARG, move across that many fields." - (interactive "p") - (custom-forward-field (- arg))) - -(defun custom-toggle-documentation (&optional arg) - "Toggle display of documentation text. -If the optional argument is non-nil, show text iff the argument is positive." - (interactive "P") - (let ((hide (or (and (null arg) - (null (custom-category-get - 'custom-documentation-properties 'invisible))) - (<= (prefix-numeric-value arg) 0)))) - (custom-category-put 'custom-documentation-properties 'invisible hide) - (custom-category-put 'custom-documentation-properties intangible hide)) - (redraw-display)) - -(defun custom-enter-value (field data) - "Enter value for current customization field or push button." - (interactive (list (get-text-property (point) 'custom-tag) - (get-text-property (point) 'custom-data))) - (cond (data - (funcall field data)) - ((eq field 'custom-enter-value) - (error "Don't be silly")) - ((and (symbolp field) (fboundp field)) - (call-interactively field)) - (field - (custom-field-query field)) - (t - (message "Nothing to enter here")))) - -(defun custom-kill-line () - "Kill to end of field or end of line, whichever is first." - (interactive) - (let ((field (get-text-property (point) 'custom-field)) - (newline (save-excursion (search-forward "\n"))) - (next (next-single-property-change (point) 'custom-field))) - (if (and field (> newline next)) - (kill-region (point) next) - (call-interactively 'kill-line)))) - -(defun custom-push-button (event) - "Activate button below mouse pointer." - (interactive "@e") - (let* ((pos (event-point event)) - (field (get-text-property pos 'custom-field)) - (tag (get-text-property pos 'custom-tag)) - (data (get-text-property pos 'custom-data))) - (cond (data - (funcall tag data)) - ((and (symbolp tag) (fboundp tag)) - (call-interactively tag)) - (field - (call-interactively (lookup-key global-map (this-command-keys)))) - (tag - (custom-enter-value tag data)) - (t - (error "Nothing to click on here."))))) - -(defun custom-reset-all () - "Undo any changes since the last apply in all fields." - (interactive (and custom-modified-list - (not (y-or-n-p "Discard all changes? ")) - (error "Reset aborted"))) - (let ((all custom-name-fields) - current field) - (while all - (setq current (car all) - field (cdr current) - all (cdr all)) - (custom-field-reset field)))) - -(defun custom-field-reset (field) - "Undo any changes in FIELD since the last apply." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (if (arrayp field) - (let* ((custom (custom-field-custom field)) - (name (custom-name custom))) - (save-excursion - (if name - (custom-field-original-set - field (car (custom-import custom (custom-external name))))) - (if (not (custom-valid custom (custom-field-original field))) - (error "This field cannot be reset alone") - (funcall (custom-property custom 'reset) field) - (funcall (custom-property custom 'synchronize) field)))))) - -(defun custom-factory-reset-all () - "Reset all field to their default values." - (interactive (and custom-modified-list - (not (y-or-n-p "Discard all changes? ")) - (error "Reset aborted"))) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (custom-field-factory-reset field)))) - -(defun custom-field-factory-reset (field) - "Reset FIELD to its default value." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (if (arrayp field) - (save-excursion - (funcall (custom-property (custom-field-custom field) 'factory-reset) - field)))) - -(defun custom-apply-all () - "Apply any changes since the last reset in all fields." - (interactive (if custom-modified-list - nil - (error "No changes to apply."))) - (custom-field-parse custom-field-last) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (let ((error (custom-field-validate (custom-field-custom field) field))) - (if (null error) - () - (goto-char (car error)) - (error (cdr error)))))) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (custom-field-apply field)))) - -(defun custom-field-apply (field) - "Apply any changes in FIELD since the last apply." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (custom-field-parse custom-field-last) - (if (arrayp field) - (let* ((custom (custom-field-custom field)) - (error (custom-field-validate custom field))) - (if error - (error (cdr error))) - (funcall (custom-property custom 'apply) field)))) - -(defun custom-toggle-hide (&rest ignore) - "Hide or show entry." - (interactive) - (error "This button is not yet implemented")) - -(defun custom-save-and-exit () - "Save and exit customization buffer." - (interactive "@") - (save-excursion - (funcall custom-save)) - (kill-buffer (current-buffer))) - -(defun custom-save () - "Save customization information." - (interactive) - (custom-apply-all) - (let ((new custom-name-fields)) - (set-buffer (find-file-noselect custom-file)) - (goto-char (point-min)) - (save-excursion - (let ((old (condition-case nil - (read (current-buffer)) - (end-of-file (append '(setq custom-dummy - 'custom-dummy) ()))))) - (or (eq (car old) 'setq) - (error "Invalid customization file: %s" custom-file)) - (while new - (let* ((field (cdr (car new))) - (custom (custom-field-custom field)) - (value (custom-field-original field)) - (default (car (custom-import custom (custom-default custom)))) - (name (car (car new)))) - (setq new (cdr new)) - (custom-assert '(eq name (custom-name custom))) - (if (equal default value) - (setcdr old (custom-plist-delq name (cdr old))) - (setcdr old (plist-put (cdr old) name - (car (custom-quote custom value))))))) - (erase-buffer) - (insert ";; " custom-file "\ - --- Automatically generated customization information. -;; -;; Feel free to edit by hand, but the entire content should consist of -;; a single setq. Any other lisp expressions will confuse the -;; automatic configuration engine. - -\(setq ") - (setq old (cdr old)) - (while old - (prin1 (car old) (current-buffer)) - (setq old (cdr old)) - (insert " ") - (pp (car old) (current-buffer)) - (setq old (cdr old)) - (if old (insert "\n "))) - (insert ")\n") - (save-buffer) - (kill-buffer (current-buffer)))))) - -(defun custom-load () - "Save customization information." - (interactive (and custom-modified-list - (not (equal (list (custom-name-field 'custom-file)) - custom-modified-list)) - (not (y-or-n-p "Discard all changes? ")) - (error "Load aborted"))) - (load-file (custom-name-value 'custom-file)) - (custom-reset-all)) - -;;; Field Editing: -;; -;; Various internal functions for implementing the direct editing of -;; fields in the customization buffer. - -(defun custom-field-untouch (field) - ;; Remove FIELD and its children from `custom-modified-list'. - (setq custom-modified-list (delq field custom-modified-list)) - (if (arrayp field) - (let ((value (custom-field-value field))) - (cond ((null (custom-data (custom-field-custom field)))) - ((arrayp value) - (custom-field-untouch value)) - ((listp value) - (mapcar 'custom-field-untouch value)))))) - - -(defun custom-field-insert (field) - ;; Insert editing FIELD in current buffer. - (let ((from (point)) - (custom (custom-field-custom field)) - (value (custom-field-value field))) - (insert (custom-write custom value)) - (insert-char (custom-padding custom) - (- (custom-width custom) (- (point) from))) - (custom-field-move field from (point)) - (custom-set-text-properties - from (point) - (list 'custom-field field - 'custom-tag field - 'face (custom-field-face field) - 'start-open t - 'end-open t)))) - -(defun custom-field-read (field) - ;; Read the screen content of FIELD. - (custom-read (custom-field-custom field) - (custom-buffer-substring-no-properties (custom-field-start field) - (custom-field-end field)))) - -;; Fields are shown in a special `active' face when point is inside -;; it. You activate the field by moving point inside (entering) it -;; and deactivate the field by moving point outside (leaving) it. - -(defun custom-field-leave (field) - ;; Deactivate FIELD. - (let ((before-change-functions nil) - (after-change-functions nil)) - (custom-put-text-property (custom-field-start field) (custom-field-end field) - 'face (custom-field-face field)))) - -(defun custom-field-enter (field) - ;; Activate FIELD. - (let* ((start (custom-field-start field)) - (end (custom-field-end field)) - (custom (custom-field-custom field)) - (padding (custom-padding custom)) - (before-change-functions nil) - (after-change-functions nil)) - (or (eq this-command 'self-insert-command) - (let ((pos end)) - (while (and (< start pos) - (eq (char-after (1- pos)) padding)) - (setq pos (1- pos))) - (if (< pos (point)) - (goto-char pos)))) - (custom-put-text-property start end 'face custom-field-active-face))) - -(defun custom-field-resize (field) - ;; Resize FIELD after change. - (let* ((custom (custom-field-custom field)) - (begin (custom-field-start field)) - (end (custom-field-end field)) - (pos (point)) - (padding (custom-padding custom)) - (width (custom-width custom)) - (size (- end begin))) - (cond ((< size width) - (goto-char end) - (if (fboundp 'insert-before-markers-and-inherit) - ;; Emacs 19. - (insert-before-markers-and-inherit - (make-string (- width size) padding)) - ;; XEmacs: BUG: Doesn't work! - (insert-before-markers (make-string (- width size) padding))) - (goto-char pos)) - ((> size width) - (let ((start (if (and (< (+ begin width) pos) (<= pos end)) - pos - (+ begin width)))) - (goto-char end) - (while (and (< start (point)) (= (preceding-char) padding)) - (backward-delete-char 1)) - (goto-char pos)))))) - -(defvar custom-field-changed nil) -;; List of fields changed on the screen but whose VALUE attribute has -;; not yet been updated to reflect the new screen content. -(make-variable-buffer-local 'custom-field-changed) - -(defun custom-field-parse (field) - ;; Parse FIELD content iff changed. - (if (memq field custom-field-changed) - (progn - (setq custom-field-changed (delq field custom-field-changed)) - (custom-field-value-set field (custom-field-read field)) - (custom-field-update field)))) - -(defun custom-post-command () - ;; Keep track of their active field. - (custom-assert '(eq major-mode 'custom-mode)) - (let ((field (custom-field-property (point)))) - (if (eq field custom-field-last) - (if (memq field custom-field-changed) - (custom-field-resize field)) - (custom-field-parse custom-field-last) - (if custom-field-last - (custom-field-leave custom-field-last)) - (if field - (custom-field-enter field)) - (setq custom-field-last field)) - (set-buffer-modified-p (or custom-modified-list - custom-field-changed)))) - -(defvar custom-field-was nil) -;; The custom data before the change. -(make-variable-buffer-local 'custom-field-was) - -(defun custom-before-change (begin end) - ;; Check that we the modification is allowed. - (if (not (eq major-mode 'custom-mode)) - (message "Aargh! Why is custom-before-change called here?") - (let ((from (custom-field-property begin)) - (to (custom-field-property end))) - (cond ((or (null from) (null to)) - (error "You can only modify the fields")) - ((not (eq from to)) - (error "Changes must be limited to a single field.")) - (t - (setq custom-field-was from)))))) - -(defun custom-after-change (begin end length) - ;; Keep track of field content. - (if (not (eq major-mode 'custom-mode)) - (message "Aargh! Why is custom-after-change called here?") - (let ((field custom-field-was)) - (custom-assert '(prog1 field (setq custom-field-was nil))) - ;; Prevent mixing fields properties. - (custom-put-text-property begin end 'custom-field field) - ;; Update the field after modification. - (if (eq (custom-field-property begin) field) - (let ((field-end (custom-field-end field))) - (if (> end field-end) - (set-marker field-end end)) - (add-to-list 'custom-field-changed field)) - ;; We deleted the entire field, reinsert it. - (custom-assert '(eq begin end)) - (save-excursion - (goto-char begin) - (custom-field-value-set field - (custom-read (custom-field-custom field) "")) - (custom-field-insert field)))))) - -(defun custom-field-property (pos) - ;; The `custom-field' text property valid for POS. - (or (get-text-property pos 'custom-field) - (and (not (eq pos (point-min))) - (get-text-property (1- pos) 'custom-field)))) - -;;; Generic Utilities: -;; -;; Some utility functions that are not really specific to custom. - -(defun custom-assert (expr) - "Assert that EXPR evaluates to non-nil at this point" - (or (eval expr) - (error "Assertion failed: %S" expr))) - -(defun custom-first-line (string) - "Return the part of STRING before the first newline." - (let ((pos 0) - (len (length string))) - (while (and (< pos len) (not (eq (aref string pos) ?\n))) - (setq pos (1+ pos))) - (if (eq pos len) - string - (substring string 0 pos)))) - -(defun custom-insert-before (list old new) - "In LIST insert before OLD a NEW element." - (cond ((null list) - (list new)) - ((null old) - (nconc list (list new))) - ((eq old (car list)) - (cons new list)) - (t - (let ((list list)) - (while (not (eq old (car (cdr list)))) - (setq list (cdr list)) - (custom-assert '(cdr list))) - (setcdr list (cons new (cdr list)))) - list))) - -(defun custom-strip-padding (string padding) - "Remove padding from STRING." - (let ((regexp (concat (regexp-quote (char-to-string padding)) "+"))) - (while (string-match regexp string) - (setq string (concat (substring string 0 (match-beginning 0)) - (substring string (match-end 0)))))) - string) - -(defun custom-plist-memq (prop plist) - "Return non-nil if PROP is a property of PLIST. Comparison done with EQ." - (let (result) - (while plist - (if (eq (car plist) prop) - (setq result plist - plist nil) - (setq plist (cdr (cdr plist))))) - result)) - -(defun custom-plist-delq (prop plist) - "Delete property PROP from property list PLIST." - (while (eq (car plist) prop) - (setq plist (cdr (cdr plist)))) - (let ((list plist) - (next (cdr (cdr plist)))) - (while next - (if (eq (car next) prop) - (progn - (setq next (cdr (cdr next))) - (setcdr (cdr list) next)) - (setq list next - next (cdr (cdr next)))))) - plist) - -;;; Meta Customization: - -(custom-declare '() - '((tag . "Meta Customization") - (doc . "Customization of the customization support.") - (type . group) - (data ((type . face-doc)) - ((tag . "Button Face") - (default . bold) - (doc . "Face used for tags in customization buffers.") - (name . custom-button-face) - (synchronize . (lambda (f) - (custom-category-put 'custom-button-properties - 'face custom-button-face))) - (type . face)) - ((tag . "Mouse Face") - (default . highlight) - (doc . "\ -Face used when mouse is above a button in customization buffers.") - (name . custom-mouse-face) - (synchronize . (lambda (f) - (custom-category-put 'custom-button-properties - mouse-face - custom-mouse-face))) - (type . face)) - ((tag . "Field Face") - (default . italic) - (doc . "Face used for customization fields.") - (name . custom-field-face) - (type . face)) - ((tag . "Uninitialized Face") - (default . modeline) - (doc . "Face used for uninitialized customization fields.") - (name . custom-field-uninitialized-face) - (type . face)) - ((tag . "Invalid Face") - (default . highlight) - (doc . "\ -Face used for customization fields containing invalid data.") - (name . custom-field-invalid-face) - (type . face)) - ((tag . "Modified Face") - (default . bold-italic) - (doc . "Face used for modified customization fields.") - (name . custom-field-modified-face) - (type . face)) - ((tag . "Active Face") - (default . underline) - (doc . "\ -Face used for customization fields while they are being edited.") - (name . custom-field-active-face) - (type . face))))) - -;; custom.el uses two categories. - -(custom-category-create 'custom-documentation-properties) -(custom-category-put 'custom-documentation-properties rear-nonsticky t) - -(custom-category-create 'custom-button-properties) -(custom-category-put 'custom-button-properties 'face custom-button-face) -(custom-category-put 'custom-button-properties mouse-face custom-mouse-face) -(custom-category-put 'custom-button-properties rear-nonsticky t) - -(custom-category-create 'custom-hidden-properties) -(custom-category-put 'custom-hidden-properties 'invisible - (not (string-match "XEmacs" emacs-version))) -(custom-category-put 'custom-hidden-properties intangible t) - -(and init-file-user ; Don't load any init file if -q was used. - (file-readable-p custom-file) - (load-file custom-file)) - -(provide 'custom) - -;;; custom.el ends here
--- a/lisp/=diary-ins.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,251 +0,0 @@ -;;; diary-ins.el --- calendar functions for adding diary entries. - -;; Copyright (C) 1990, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: diary, calendar - -;; 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: - -;; This collection of functions implements the diary insertion features as -;; described in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'diary-lib) - -(defun make-diary-entry (string &optional nonmarking file) - "Insert a diary entry STRING which may be NONMARKING in FILE. -If omitted, NONMARKING defaults to nil and FILE defaults to diary-file." - (find-file-other-window - (substitute-in-file-name (if file file diary-file))) - (goto-char (point-max)) - (insert - (if (bolp) "" "\n") - (if nonmarking diary-nonmarking-symbol "") - string " ")) - -(defun insert-diary-entry (arg) - "Insert a diary entry for the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t t) - arg)) - -(defun insert-weekly-diary-entry (arg) - "Insert a weekly diary entry for the day of the week indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-day-name (calendar-cursor-to-date t)) - arg)) - -(defun insert-monthly-diary-entry (arg) - "Insert a monthly diary entry for the day of the month indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " * ") - '("* " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-yearly-diary-entry (arg) - "Insert an annual diary entry for the day of the year indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-anniversary-diary-entry (arg) - "Insert an anniversary diary entry for the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-anniversary %s)" - sexp-diary-entry-symbol - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(defun insert-block-diary-entry (arg) - "Insert a block diary entry for the days between the point and marked date. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year))) - (cursor (calendar-cursor-to-date t)) - (mark (or (car calendar-mark-ring) - (error "No mark set in this buffer"))) - (start) - (end)) - (if (< (calendar-absolute-from-gregorian mark) - (calendar-absolute-from-gregorian cursor)) - (setq start mark - end cursor) - (setq start cursor - end mark)) - (make-diary-entry - (format "%s(diary-block %s %s)" - sexp-diary-entry-symbol - (calendar-date-string start nil t) - (calendar-date-string end nil t)) - arg))) - -(defun insert-cyclic-diary-entry (arg) - "Insert a cyclic diary entry starting at the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-cyclic %d %s)" - sexp-diary-entry-symbol - (calendar-read "Repeat every how many days: " - '(lambda (x) (> x 0))) - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(defun insert-hebrew-diary-entry (arg) - "Insert a diary entry. -For the Hebrew date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-hebrew-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Hebrew month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-hebrew-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Hebrew year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-islamic-diary-entry (arg) - "Insert a diary entry. -For the Islamic date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-islamic-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Islamic month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-islamic-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Islamic year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(provide 'diary-ins) - -;;; diary-ins.el ends here
--- a/lisp/=diary-lib.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1919 +0,0 @@ -;;; diary-lib.el --- diary functions. - -;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar - -;; 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: - -;; This collection of functions implements the diary features as described -;; in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) - -;;;###autoload -(defun diary (&optional arg) - "Generate the diary window for ARG days starting with the current date. -If no argument is provided, the number of days of diary entries is governed -by the variable `number-of-diary-entries'. This function is suitable for -execution in a `.emacs' file." - (interactive "P") - (let ((d-file (substitute-in-file-name diary-file)) - (date (calendar-current-date))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries - date - (cond - (arg (prefix-numeric-value arg)) - ((vectorp number-of-diary-entries) - (aref number-of-diary-entries (calendar-day-of-week date))) - (t number-of-diary-entries))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-diary-entries (arg) - "Prepare and display a buffer with diary entries. -Searches the file named in `diary-file' for entries that -match ARG days starting with the date indicated by the cursor position -in the displayed three-month calendar." - (interactive "p") - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries (calendar-cursor-to-date t) arg) - (error "Diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-other-diary-entries (arg diary-file) - "Prepare and display buffer of diary entries from an alternative diary file. -Prompts for a file name and searches that file for entries that match ARG -days starting with the date indicated by the cursor position in the displayed -three-month calendar." - (interactive - (list (cond ((null current-prefix-arg) 1) - ((listp current-prefix-arg) (car current-prefix-arg)) - (t current-prefix-arg)) - (setq diary-file (read-file-name "Enter diary file name: " - default-directory nil t)))) - (view-diary-entries arg)) - -(autoload 'check-calendar-holidays "holidays" - "Check the list of holidays for any that occur on DATE. -The value returned is a list of strings of relevant holiday descriptions. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'calendar-holiday-list "holidays" - "Form the list of holidays that occur on dates in the calendar window. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'diary-french-date "cal-french" - "French calendar equivalent of date diary entry." - t) - -(autoload 'diary-mayan-date "cal-mayan" - "Mayan calendar equivalent of date diary entry." - t) - -(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t) - -(autoload 'diary-sunrise-sunset "solar" - "Local time of sunrise and sunset as a diary entry." - t) - -(autoload 'diary-sabbath-candles "solar" - "Local time of candle lighting diary entry--applies if date is a Friday. -No diary entry if there is no sunset on that date." - t) - -(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table)) - "The syntax table used when parsing dates in the diary file. -It is the standard syntax table used in Fundamental mode, but with the -syntax of `*' changed to be a word constituent.") - -(modify-syntax-entry ?* "w" diary-syntax-table) - -(defun list-diary-entries (date number) - "Create and display a buffer containing the relevant lines in diary-file. -The arguments are DATE and NUMBER; the entries selected are those -for NUMBER days starting with date DATE. The other entries are hidden -using selective display. - -Returns a list of all relevant diary entries found, if any, in order by date. -The list entries have the form ((month day year) string). If the variable -`diary-list-include-blanks' is t, this list includes a dummy diary entry -\(consisting of the empty string) for a date with no diary entries. - -After the list is prepared, the hooks `nongregorian-diary-listing-hook', -`list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run. -These hooks have the following distinct roles: - - `nongregorian-diary-listing-hook' can cull dates from the diary - and each included file. Usually used for Hebrew or Islamic - diary entries in files. Applied to *each* file. - - `list-diary-entries-hook' adds or manipulates diary entries from - external sources. Used, for example, to include diary entries - from other files or to sort the diary entries. Invoked *once* only, - before the display hook is run. - - `diary-display-hook' does the actual display of information. If this is - nil, simple-diary-display will be used. Use add-hook to set this to - fancy-diary-display, if desired. If you want no diary display, use - add-hook to set this to ignore. - - `diary-hook' is run last. This can be used for an appointment - notification function." - - (if (< 0 number) - (let* ((original-date date);; save for possible use in the hooks - (old-diary-syntax-table) - (diary-entries-list) - (date-string (calendar-date-string date)) - (d-file (substitute-in-file-name diary-file))) - (message "Preparing diary...") - (save-excursion - (let ((diary-buffer (get-file-buffer d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-file t)))) - (setq selective-display t) - (setq selective-display-ellipses nil) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (unwind-protect - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (mark (regexp-quote diary-nonmarking-symbol))) - (goto-char (1- (point-max))) - (if (not (looking-at "\^M\\|\n")) - (progn - (forward-char 1) - (insert-string "\^M"))) - (goto-char (point-min)) - (if (not (looking-at "\^M\\|\n")) - (insert-string "\^M")) - (subst-char-in-region (point-min) (point-max) ?\n ?\^M t) - (calendar-for-loop i from 1 to number do - (let ((d diary-date-forms) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (entry-found (list-sexp-diary-entries date))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name date) "\\|" - (substring (calendar-day-name date) 0 3) ".?")) - (monthname - (concat - "\\*\\|" - (calendar-month-name month) "\\|" - (substring (calendar-month-name month) 0 3) ".?")) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (setq entry-found t) - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start - (point) ?\^M ?\n t) - (add-to-diary-list - date (buffer-substring entry-start (point))))))) - (setq d (cdr d))) - (or entry-found - (not diary-list-include-blanks) - (setq diary-entries-list - (append diary-entries-list - (list (list date ""))))) - (setq date - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian date)))) - (setq entry-found nil))) - (set-buffer-modified-p diary-modified)) - (set-syntax-table old-diary-syntax-table)) - (goto-char (point-min)) - (run-hooks 'nongregorian-diary-listing-hook - 'list-diary-entries-hook) - (if diary-display-hook - (run-hooks 'diary-display-hook) - (simple-diary-display)) - (run-hooks 'diary-hook) - diary-entries-list)))) - -(defun include-other-diary-files () - "Include the diary entries from other diary files with those of diary-file. -This function is suitable for use in `list-diary-entries-hook'; -it enables you to use shared diary files together with your own. -The files included are specified in the diaryfile by lines of this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring (match-beginning 2) (match-end 2)))) - (diary-list-include-blanks nil) - (list-diary-entries-hook 'include-other-diary-files) - (diary-display-hook 'ignore) - (diary-hook nil)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (unwind-protect - (setq diary-entries-list - (append diary-entries-list - (list-diary-entries original-date number))) - (kill-buffer (get-file-buffer diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun simple-diary-display () - "Display the diary buffer if there are any relevant entries or holidays." - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string)) - (calendar-set-mode-line - (concat "Diary for " date-string - (if holiday-list ": " "") - (mapconcat 'identity holiday-list "; "))) - (display-buffer (get-file-buffer d-file)) - (message "Preparing diary...done")))) - -(defun fancy-diary-display () - "Prepare a diary buffer with relevant entries in a fancy, noneditable form. -This function is provided for optional use as the `diary-display-hook'." - (save-excursion;; Turn off selective-display in the diary file's buffer. - (set-buffer (get-file-buffer (substitute-in-file-name diary-file))) - (let ((diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (kill-local-variable 'mode-line-format) - (set-buffer-modified-p diary-modified))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string))) - (save-excursion;; Prepare the fancy diary buffer. - (set-buffer (make-fancy-diary-buffer)) - (setq buffer-read-only nil) - (let ((entry-list diary-entries-list) - (holiday-list) - (holiday-list-last-month 1) - (holiday-list-last-year 1) - (date (list 0 0 0))) - (while entry-list - (if (not (calendar-date-equal date (car (car entry-list)))) - (progn - (setq date (car (car entry-list))) - (and holidays-in-diary-buffer - (calendar-date-compare - (list (list holiday-list-last-month - (calendar-last-day-of-month - holiday-list-last-month - holiday-list-last-year) - holiday-list-last-year)) - (list date)) - ;; We need to get the holidays for the next 3 months. - (setq holiday-list-last-month - (extract-calendar-month date)) - (setq holiday-list-last-year - (extract-calendar-year date)) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1) - (setq holiday-list - (let ((displayed-month holiday-list-last-month) - (displayed-year holiday-list-last-year)) - (calendar-holiday-list))) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1)) - (let* ((date-string (calendar-date-string date)) - (date-holiday-list - (let ((h holiday-list) - (d)) - ;; Make a list of all holidays for date. - (while h - (if (calendar-date-equal date (car (car h))) - (setq d (append d (cdr (car h))))) - (setq h (cdr h))) - d))) - (insert (if (= (point) (point-min)) "" ?\n) date-string) - (if date-holiday-list (insert ": ")) - (let ((l (current-column))) - (insert (mapconcat 'identity date-holiday-list - (concat "\n" (make-string l ? ))))) - (let ((l (current-column))) - (insert ?\n (make-string l ?=) ?\n))))) - (if (< 0 (length (car (cdr (car entry-list))))) - (insert (car (cdr (car entry-list))) ?\n)) - (setq entry-list (cdr entry-list)))) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (setq buffer-read-only t) - (display-buffer fancy-diary-buffer) - (message "Preparing diary...done")))) - -(defun make-fancy-diary-buffer () - "Create and return the initial fancy diary buffer." - (save-excursion - (set-buffer (get-buffer-create fancy-diary-buffer)) - (setq buffer-read-only nil) - (make-local-variable 'mode-line-format) - (calendar-set-mode-line "Diary Entries") - (erase-buffer) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (get-buffer fancy-diary-buffer))) - -(defun print-diary-entries () - "Print a hard copy of the diary display. - -If the simple diary display is being used, prepare a temp buffer with the -visible lines of the diary buffer, add a heading line composed from the mode -line, print the temp buffer, and destroy it. - -If the fancy diary display is being used, just print the buffer. - -The hooks given by the variable `print-diary-entries-hook' are called to do -the actual printing." - (interactive) - (if (bufferp (get-buffer fancy-diary-buffer)) - (save-excursion - (set-buffer (get-buffer fancy-diary-buffer)) - (run-hooks 'print-diary-entries-hook)) - (let ((diary-buffer - (get-file-buffer (substitute-in-file-name diary-file)))) - (if diary-buffer - (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*")) - (heading)) - (save-excursion - (set-buffer diary-buffer) - (setq heading - (if (not (stringp mode-line-format)) - "All Diary Entries" - (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format) - (substring mode-line-format - (match-beginning 1) (match-end 1)))) - (copy-to-buffer temp-buffer (point-min) (point-max)) - (set-buffer temp-buffer) - (while (re-search-forward "\^M.*$" nil t) - (replace-match "")) - (goto-char (point-min)) - (insert heading "\n" - (make-string (length heading) ?=) "\n") - (run-hooks 'print-diary-entries-hook) - (kill-buffer temp-buffer))) - (error "You don't have a diary buffer!"))))) - -(defun show-all-diary-entries () - "Show all of the diary entries in the diary file. -This function gets rid of the selective display of the diary file so that -all entries, not just some, are visible. If there is no diary buffer, one -is created." - (interactive) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (let ((diary-buffer (get-file-buffer d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-file t))) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (make-local-variable 'mode-line-format) - (setq mode-line-format default-mode-line-format) - (display-buffer (current-buffer)) - (set-buffer-modified-p diary-modified)))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun diary-name-pattern (string-array &optional fullname) - "Convert an STRING-ARRAY, an array of strings to a pattern. -The pattern will match any of the strings, either entirely or abbreviated -to three characters. An abbreviated form will match with or without a period; -If the optional FULLNAME is t, abbreviations will not match, just the full -name." - (let ((pattern "")) - (calendar-for-loop i from 0 to (1- (length string-array)) do - (setq pattern - (concat - pattern - (if (string-equal pattern "") "" "\\|") - (aref string-array i) - (if fullname - "" - (concat - "\\|" - (substring (aref string-array i) 0 3) ".?"))))) - pattern)) - -(defun mark-diary-entries () - "Mark days in the calendar window that have diary entries. -Each entry in the diary file visible in the calendar window is marked. -After the entries are marked, the hooks `nongregorian-diary-marking-hook' and -`mark-diary-entries-hook' are run." - (interactive) - (setq mark-diary-entries-in-calendar t) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (message "Marking diary entries...") - (set-buffer (find-file-noselect d-file t)) - (let ((d diary-date-forms) - (old-diary-syntax-table)) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-month-name-array) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-current-date))) - (y (+ (string-to-int y-str) - (* 100 - (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize - (substring mm-name 0 3)) - (calendar-make-alist - calendar-month-name-array - 1 - '(lambda (x) (substring x 0 3))) - ))))) - (mark-calendar-date-pattern mm dd yy)))) - (setq d (cdr d)))) - (mark-sexp-diary-entries) - (run-hooks 'nongregorian-diary-marking-hook - 'mark-diary-entries-hook) - (set-syntax-table old-diary-syntax-table) - (message "Marking diary entries...done"))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun mark-sexp-diary-entries () - "Mark days in the calendar window that have sexp diary entries. -Each entry in the diary file (or included files) visible in the calendar window -is marked. See the documentation for the function `list-sexp-diary-entries'." - (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "(")) - (m) - (y) - (first-date) - (last-date)) - (save-excursion - (set-buffer calendar-buffer) - (setq m displayed-month) - (setq y displayed-year)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (backward-char 1) - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (calendar-for-loop date from first-date to last-date do - (if (diary-sexp-entry sexp entry - (calendar-gregorian-from-absolute date)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date)))))))) - -(defun mark-included-diary-files () - "Mark the diary entries from other diary files with those of the diary file. -This function is suitable for use as the `mark-diary-entries-hook'; it enables -you to use shared diary files together with your own. The files included are -specified in the diary-file by lines of this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring (match-beginning 2) (match-end 2)))) - (mark-diary-entries-hook 'mark-included-diary-files)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (progn - (mark-diary-entries) - (kill-buffer (get-file-buffer diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun mark-calendar-days-named (dayname) - "Mark all dates in the calendar window that are day DAYNAME of the week. -0 means all Sundays, 1 means all Mondays, and so on." - (save-excursion - (set-buffer calendar-buffer) - (let ((prev-month displayed-month) - (prev-year displayed-year) - (succ-month displayed-month) - (succ-year displayed-year) - (last-day) - (day)) - (increment-calendar-month succ-month succ-year 1) - (increment-calendar-month prev-month prev-year -1) - (setq day (calendar-absolute-from-gregorian - (calendar-nth-named-day 1 dayname prev-month prev-year))) - (setq last-day (calendar-absolute-from-gregorian - (calendar-nth-named-day -1 dayname succ-month succ-year))) - (while (<= day last-day) - (mark-visible-calendar-date (calendar-gregorian-from-absolute day)) - (setq day (+ day 7)))))) - -(defun mark-calendar-date-pattern (month day year) - "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y -1) - (calendar-for-loop i from 0 to 2 do - (mark-calendar-month m y month day year) - (increment-calendar-month m y 1))))) - -(defun mark-calendar-month (month year p-month p-day p-year) - "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR. -A value of 0 in any position of the pattern is a wildcard." - (if (or (and (= month p-month) - (or (= p-year 0) (= year p-year))) - (and (= p-month 0) - (or (= p-year 0) (= year p-year)))) - (if (= p-day 0) - (calendar-for-loop - i from 1 to (calendar-last-day-of-month month year) do - (mark-visible-calendar-date (list month i year))) - (mark-visible-calendar-date (list month p-day year))))) - -(defun sort-diary-entries () - "Sort the list of diary entries by time of day." - (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) - -(defun diary-entry-compare (e1 e2) - "Returns t if E1 is earlier than E2." - (or (calendar-date-compare e1 e2) - (and (calendar-date-equal (car e1) (car e2)) - (< (diary-entry-time (car (cdr e1))) - (diary-entry-time (car (cdr e2))))))) - -(defun diary-entry-time (s) - "Time at the beginning of the string S in a military-style integer. -For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized. -The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm, -and XX:XXam or XX:XXpm." - (cond ((string-match;; Military time - "^[ \t]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s) - (+ (* 100 (string-to-int - (substring s (match-beginning 1) (match-end 1)))) - (string-to-int (substring s (match-beginning 2) (match-end 2))))) - ((string-match;; Hour only XXam or XXpm - "^[ \t]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (if (string-equal "a" - (substring s (match-beginning 2) (match-end 2))) - 0 1200))) - ((string-match;; Hour and minute XX:XXam or XX:XXpm - "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (string-to-int (substring s (match-beginning 2) (match-end 2))) - (if (string-equal "a" - (substring s (match-beginning 3) (match-end 3))) - 0 1200))) - (t -9999)));; Unrecognizable - -(defun list-hebrew-diary-entries () - "Add any Hebrew date entries from the diary file to `diary-entries-list'. -Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol' -\(normally an `H'). The same diary date forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. If a Hebrew date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (hdate (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month hdate)) - (day (extract-calendar-day hdate)) - (year (extract-calendar-year hdate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-hebrew-diary-entries () - "Mark days in the calendar window that have Hebrew date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol -\(normally an `H'). The same diary-date-forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. Hebrew date diary entries that begin with a -diary-nonmarking symbol will not be marked in the calendar. This function -is provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-hebrew-month-name-array-leap-year t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq - mm - (cdr - (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-hebrew-month-name-array-leap-year)))))) - (mark-hebrew-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-hebrew-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Hebrew date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (if (memq displayed-month;; This test is only to speed things up a - (list ;; bit; it works fine without the test too. - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 - (calendar-last-day-of-month m2 y2) - y2))) - (hebrew-start - (calendar-hebrew-from-absolute start-date)) - (hebrew-end (calendar-hebrew-from-absolute end-date)) - (hebrew-y1 (extract-calendar-year hebrew-start)) - (hebrew-y2 (extract-calendar-year hebrew-end))) - (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((h-date (calendar-hebrew-from-absolute date)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date))) - (and (or (zerop month) - (= month h-month)) - (or (zerop day) - (= day h-day)) - (or (zerop year) - (= year h-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(defun list-sexp-diary-entries (date) - "Add sexp entries for DATE from the diary file to `diary-entries-list'. -Also, Make them visible in the diary file. Returns t if any entries were -found. - -Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally -`%%'). The form of a sexp diary entry is - - %%(SEXP) ENTRY - -Both ENTRY and DATE are globally available when the SEXP is evaluated. If the -SEXP yields the value nil, the diary entry does not apply. If it yields a -non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a -string, that string will be the diary entry in the fancy diary display. - -For example, the following diary entry will apply to the 21st of the month -if it is a weekday and the Friday before if the 21st is on a weekend: - - &%%(let ((dayname (calendar-day-of-week date)) - (day (extract-calendar-day date))) - (or - (and (= day 21) (memq dayname '(1 2 3 4 5))) - (and (memq day '(19 20)) (= dayname 5))) - ) UIUC pay checks deposited - -A number of built-in functions are available for this type of diary entry: - - %%(diary-float MONTH DAYNAME N) text - Entry will appear on the Nth DAYNAME of MONTH. - (DAYNAME=0 means Sunday, 1 means Monday, and so on; - if N is negative it counts backward from the end of - the month. MONTH can be a list of months, a single - month, or t to specify all months. - - %%(diary-block M1 D1 Y1 M2 D2 Y2) text - Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2, - inclusive. (If `european-calendar-style' is t, the - order of the parameters should be changed to D1, M1, Y1, - D2, M2, Y2.) - - %%(diary-anniversary MONTH DAY YEAR) text - Entry will appear on anniversary dates of MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of years since the MONTH DAY, YEAR and %s will be replaced - by the ordinal ending of that number (that is, `st', `nd', - `rd' or `th', as appropriate. The anniversary of February - 29 is considered to be March 1 in a non-leap year. - - %%(diary-cyclic N MONTH DAY YEAR) text - Entry will appear every N days, starting MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to N, DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of repetitions since the MONTH DAY, YEAR and %s will - be replaced by the ordinal ending of that number (that is, - `st', `nd', `rd' or `th', as appropriate. - - %%(diary-day-of-year) - Diary entries giving the day of the year and the number of - days remaining in the year will be made every day. Note - that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-iso-date) - Diary entries giving the corresponding ISO commercial date - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - - %%(diary-french-date) - Diary entries giving the corresponding French Revolutionary - date will be made every day. Note that since there is no - text, it makes sense only if the fancy diary display is used. - - %%(diary-islamic-date) - Diary entries giving the corresponding Islamic date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-hebrew-date) - Diary entries giving the corresponding Hebrew date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-astro-day-number) Diary entries giving the corresponding - astronomical (Julian) day number will be made every day. - Note that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-julian-date) Diary entries giving the corresponding - Julian date will be made every day. Note that since - there is no text, it makes sense only if the fancy diary - display is used. - - %%(diary-sunrise-sunset) - Diary entries giving the local times of sunrise and sunset - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-phases-of-moon) - Diary entries giving the times of the phases of the moon - will be when appropriate. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-yahrzeit MONTH DAY YEAR) text - Text is assumed to be the name of the person; the date is - the date of death on the *civil* calendar. The diary entry - will appear on the proper Hebrew-date anniversary and on the - day before. (If `european-calendar-style' is t, the order - of the parameters should be changed to DAY, MONTH, YEAR.) - - %%(diary-rosh-hodesh) - Diary entries will be made on the dates of Rosh Hodesh on - the Hebrew calendar. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-parasha) - Diary entries giving the weekly parasha will be made on - every Saturday. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-omer) - Diary entries giving the omer count will be made every day - from Passover to Shavuoth. Note that since there is no text, - it makes sense only if the fancy diary display is used. - -Marking these entries is *extremely* time consuming, so these entries are -best if they are nonmarking." - (let* ((mark (regexp-quote diary-nonmarking-symbol)) - (sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) - (entry-found)) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (backward-char 1) - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (let ((diary-entry (diary-sexp-entry sexp entry date))) - (if diary-entry - (subst-char-in-region line-start (point) ?\^M ?\n t)) - (add-to-diary-list date diary-entry) - (setq entry-found (or entry-found diary-entry))))) - entry-found)) - -(defun diary-sexp-entry (sexp entry date) - "Process a SEXP diary ENTRY for DATE." - (let ((result (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car (read-from-string sexp)))) - (condition-case nil - (eval (car (read-from-string sexp))) - (error - (beep) - (message "Bad sexp at line %d in %s: %s" - (save-excursion - (save-restriction - (narrow-to-region 1 (point)) - (goto-char (point-min)) - (let ((lines 1)) - (while (re-search-forward "\n\\|\^M" nil t) - (setq lines (1+ lines))) - lines))) - diary-file sexp) - (sleep-for 2)))))) - (if (stringp result) - result - (if result - entry - nil)))) - -(defun diary-block (m1 d1 y1 m2 d2 y2) - "Block diary entry. -Entry applies if date is between two dates. Order of the parameters is -M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and -D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t." - (let ((date1 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d1 m1 y1) - (list m1 d1 y1)))) - (date2 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d2 m2 y2) - (list m2 d2 y2)))) - (d (calendar-absolute-from-gregorian date))) - (if (and (<= date1 d) (<= d date2)) - entry))) - -(defun diary-float (month dayname n) - "Floating diary entry--entry applies if date is the nth dayname of month. -Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant -t, or an integer. The constant t means all months. If N is negative, count -backward from the end of the month." - (let ((m (extract-calendar-month date)) - (y (extract-calendar-year date))) - (if (and - (or (and (listp month) (memq m month)) - (equal m month) - (eq month t)) - (calendar-date-equal date (calendar-nth-named-day n dayname m y))) - entry))) - -(defun diary-anniversary (month day year) - "Anniversary diary entry. -Entry applies if date is the anniversary of MONTH, DAY, YEAR if -`european-calendar-style' is nil, and DAY, MONTH, YEAR if -`european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the -%d will be replaced by the number of years since the MONTH DAY, YEAR and the -%s will be replaced by the ordinal ending of that number (that is, `st', `nd', -`rd' or `th', as appropriate. The anniversary of February 29 is considered -to be March 1 in non-leap years." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (y (extract-calendar-year date)) - (diff (- y year))) - (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y))) - (setq m 3 - d 1)) - (if (and (> diff 0) (calendar-date-equal (list m d y) date)) - (format entry diff (diary-ordinal-suffix diff))))) - -(defun diary-cyclic (n month day year) - "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR. -If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR. -ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of -years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal -ending of that number (that is, `st', `nd', `rd' or `th', as appropriate." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (diff (- (calendar-absolute-from-gregorian date) - (calendar-absolute-from-gregorian - (list m d year)))) - (cycle (/ diff n))) - (if (and (>= diff 0) (zerop (% diff n))) - (format entry cycle (diary-ordinal-suffix cycle))))) - -(defun diary-ordinal-suffix (n) - "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)" - (if (or (memq (% n 100) '(11 12 13)) - (< 3 (% n 10))) - "th" - (aref ["th" "st" "nd" "rd"] (% n 10)))) - -(defun diary-day-of-year () - "Day of year and number of days remaining in the year of date diary entry." - (calendar-day-of-year-string date)) - -(defun diary-iso-date () - "ISO calendar equivalent of date diary entry." - (format "ISO date: %s" (calendar-iso-date-string date))) - -(defun diary-islamic-date () - "Islamic calendar equivalent of date diary entry." - (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t)))) - (if (string-equal i "") - "Date is pre-Islamic" - (format "Islamic date (until sunset): %s" i)))) - -(defun diary-hebrew-date () - "Hebrew calendar equivalent of date diary entry." - (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date))) - -(defun diary-julian-date () - "Julian calendar equivalent of date diary entry." - (format "Julian date: %s" (calendar-julian-date-string date))) - -(defun diary-astro-day-number () - "Astronomical (Julian) day number diary entry." - (format "Astronomical (Julian) day number %s" - (calendar-astro-date-string date))) - -(defun diary-omer () - "Omer count diary entry. -Entry applies if date is within 50 days after Passover." - (let* ((passover - (calendar-absolute-from-hebrew - (list 1 15 (+ (extract-calendar-year date) 3760)))) - (omer (- (calendar-absolute-from-gregorian date) passover)) - (week (/ omer 7)) - (day (% omer 7))) - (if (and (> omer 0) (< omer 50)) - (format "Day %d%s of the omer (until sunset)" - omer - (if (zerop week) - "" - (format ", that is, %d week%s%s" - week - (if (= week 1) "" "s") - (if (zerop day) - "" - (format " and %d day%s" - day (if (= day 1) "" "s"))))))))) - -(defun diary-yahrzeit (death-month death-day death-year) - "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before. -Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed -to be the name of the person. Date of death is on the *civil* calendar; -although the date of death is specified by the civil calendar, the proper -Hebrew calendar yahrzeit is determined. If `european-calendar-style' is t, the -order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR." - (let* ((h-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (if european-calendar-style - (list death-day death-month death-year) - (list death-month death-day death-year))))) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (d (calendar-absolute-from-gregorian date)) - (yr (extract-calendar-year (calendar-hebrew-from-absolute d))) - (diff (- yr h-year)) - (y (hebrew-calendar-yahrzeit h-date yr))) - (if (and (> diff 0) (or (= y d) (= y (1+ d)))) - (format "Yahrzeit of %s%s: %d%s anniversary" - entry - (if (= y d) "" " (evening)") - diff - (cond ((= (% diff 10) 1) "st") - ((= (% diff 10) 2) "nd") - ((= (% diff 10) 3) "rd") - (t "th")))))) - -(defun diary-rosh-hodesh () - "Rosh Hodesh diary entry. -Entry applies if date is Rosh Hodesh, the day before, or the Saturday before." - (let* ((d (calendar-absolute-from-gregorian date)) - (h-date (calendar-hebrew-from-absolute d)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (leap-year (hebrew-calendar-leap-year-p h-year)) - (last-day (hebrew-calendar-last-day-of-month h-month h-year)) - (h-month-names - (if leap-year - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year)) - (this-month (aref h-month-names (1- h-month))) - (h-yesterday (extract-calendar-day - (calendar-hebrew-from-absolute (1- d))))) - (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7))) - (format - "Rosh Hodesh %s" - (if (= h-day 30) - (format - "%s (first day)" - ;; next month must be in the same year since this - ;; month can't be the last month of the year since - ;; it has 30 days - (aref h-month-names h-month)) - (if (= h-yesterday 30) - (format "%s (second day)" this-month) - this-month))) - (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim - (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s)" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)) - (aref calendar-day-name-array (- 29 h-day)))) - ((and (< h-day 30) (> h-day 22) (= 30 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s-%s)" - (aref h-month-names h-month) - (if (= h-day 29) - "tomorrow" - (aref calendar-day-name-array (- 29 h-day))) - (aref calendar-day-name-array - (% (- 30 h-day) 7))))) - (if (and (= h-day 29) (/= h-month 6)) - (format "Erev Rosh Hodesh %s" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)))))))) - -(defun diary-parasha () - "Parasha diary entry--entry applies if date is a Saturday." - (let ((d (calendar-absolute-from-gregorian date))) - (if (= (% d 7) 6);; Saturday - (let* - ((h-year (extract-calendar-year - (calendar-hebrew-from-absolute d))) - (rosh-hashannah - (calendar-absolute-from-hebrew (list 7 1 h-year))) - (passover - (calendar-absolute-from-hebrew (list 1 15 h-year))) - (rosh-hashannah-day - (aref calendar-day-name-array (% rosh-hashannah 7))) - (passover-day - (aref calendar-day-name-array (% passover 7))) - (long-h (hebrew-calendar-long-heshvan-p h-year)) - (short-k (hebrew-calendar-short-kislev-p h-year)) - (type (cond ((and long-h (not short-k)) "complete") - ((and (not long-h) short-k) "incomplete") - (t "regular"))) - (year-format - (symbol-value - (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah - rosh-hashannah-day type passover-day)))) - (first-saturday;; of Hebrew year - (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah))) - (saturday;; which Saturday of the Hebrew year - (/ (- d first-saturday) 7)) - (parasha (aref year-format saturday))) - (if parasha - (format - "Parashat %s" - (if (listp parasha);; Israel differs from diaspora - (if (car parasha) - (format "%s (diaspora), %s (Israel)" - (hebrew-calendar-parasha-name (car parasha)) - (hebrew-calendar-parasha-name (cdr parasha))) - (format "%s (Israel)" - (hebrew-calendar-parasha-name (cdr parasha)))) - (hebrew-calendar-parasha-name parasha)))))))) - -(defun add-to-diary-list (date string) - "Add the entry (DATE STRING) to `diary-entries-list'. -Do nothing if DATE or STRING is nil." - (and date string - (setq diary-entries-list - (append diary-entries-list (list (list date string)))))) - -(defvar hebrew-calendar-parashiot-names -["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth" - "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi" - "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim" - "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra" - "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim" - "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha" - "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth" - "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim" - "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"] - "The names of the parashiot in the Torah.") - -;; The seven ordinary year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Sunday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have -29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Saturday-complete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Tuesday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-complete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Thursday-regular-Saturday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23 - 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30) - (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48 - 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-complete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Sunday.") - -;; The seven leap year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Saturday-complete-Thursday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-complete-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-incomplete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both -have 29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Thursday-complete-Tuesday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both -have 30 days), and has Passover start on Tuesday.") - -(defun hebrew-calendar-parasha-name (p) - "Name(s) corresponding to parasha P." - (if (arrayp p);; combined parasha - (format "%s/%s" - (aref hebrew-calendar-parashiot-names (aref p 0)) - (aref hebrew-calendar-parashiot-names (aref p 1))) - (aref hebrew-calendar-parashiot-names p))) - -(defun list-islamic-diary-entries () - "Add any Islamic date entries from the diary file to `diary-entries-list'. -Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol' -\(normally an `I'). The same diary date forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. If an Islamic date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (idate (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month idate)) - (day (extract-calendar-day idate)) - (year (extract-calendar-year idate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-islamic-month-name-array) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-islamic-diary-entries () - "Mark days in the calendar window that have Islamic date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol -\(normally an `I'). The same diary-date-forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. Islamic date diary entries that begin with a -diary-nonmarking-symbol will not be marked in the calendar. This function is -provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-islamic-month-name-array t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-islamic-month-name-array)))))) - (mark-islamic-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-islamic-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Islamic date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (extract-calendar-month islamic-date)) - (y (extract-calendar-year islamic-date)) - (date)) - (if (< m 1) - nil;; Islamic calendar doesn't apply. - (increment-calendar-month m y (- 10 month)) - (if (> m 7);; Islamic date might be visible - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day y))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((i-date (calendar-islamic-from-absolute date)) - (i-month (extract-calendar-month i-date)) - (i-day (extract-calendar-day i-date)) - (i-year (extract-calendar-year i-date))) - (and (or (zerop month) - (= month i-month)) - (or (zerop day) - (= day i-day)) - (or (zerop year) - (= year i-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(provide 'diary-lib) - -;;; diary-lib.el ends here
--- a/lisp/=ftp.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,392 +0,0 @@ -;;; ftp.el --- file input and output over Internet using FTP - -;; Copyright (C) 1987 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik <mly@prep.ai.mit.edu> - -;; 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. - -;;; Code: - -;; Prevent changes in major modes from altering these variables. -(put 'ftp-temp-file-name 'permanent-local t) -(put 'ftp-file 'permanent-local t) -(put 'ftp-host 'permanent-local t) - -;; you can turn this off by doing -;; (setq ftp-password-alist 'compulsory-urinalysis) -(defvar ftp-password-alist () "Security sucks") - -(defun read-ftp-user-password (host user new) - (let (tem) - (if (and (not new) - (listp ftp-password-alist) - (setq tem (cdr (assoc host ftp-password-alist))) - (or (null user) - (string= user (car tem)))) - tem - (or user - (progn - (setq tem (or (and (listp ftp-password-alist) - (car (cdr (assoc host ftp-password-alist)))) - (user-login-name))) - (setq user (read-string (format - "User-name for %s (default \"%s\"): " - host tem))) - (if (equal user "") (setq user tem)))) - (setq tem (cons user - ;; If you want to use some non-echoing string-reader, - ;; feel free to write it yourself. I don't care enough. - (read-string (format "Password for %s@%s: " user host) - (if (not (listp ftp-password-alist)) - "" - (or (cdr (cdr (assoc host ftp-password-alist))) - (let ((l ftp-password-alist)) - (catch 'foo - (while l - (if (string= (car (cdr (car l))) user) - (throw 'foo (cdr (cdr (car l)))) - (setq l (cdr l)))) - nil)) - ""))))) - (message "") - (if (and (listp ftp-password-alist) - (not (string= (cdr tem) ""))) - (setq ftp-password-alist (cons (cons host tem) - ftp-password-alist))) - tem))) - -(defun ftp-read-file-name (prompt) - (let ((s "")) - (while (not (string-match "\\`[ \t]*\\([^ \t:]+\\)[ \t]*:\\(.+\\)\\'" s)) - (setq s (read-string prompt s))) - (list (substring s (match-beginning 1) (match-end 1)) - (substring s (match-beginning 2) (match-end 2))))) - - -;;;###autoload -(defun ftp-find-file (host file &optional user password) - "FTP to HOST to get FILE, logging in as USER with password PASSWORD. -Interactively, HOST and FILE are specified by reading a string with - a colon character separating the host from the filename. -USER and PASSWORD are defaulted from the values used when - last ftping from HOST (unless password-remembering is disabled). - Supply a password of the symbol `t' to override this default - (interactively, this is done by giving a prefix arg)" - (interactive - (append (ftp-read-file-name "FTP get host:file: ") - (list nil (not (null current-prefix-arg))))) - (ftp-find-file-or-directory host file t user password)) - -;;;###autoload -(defun ftp-list-directory (host file &optional user password) - "FTP to HOST to list DIRECTORY, logging in as USER with password PASSWORD. -Interactively, HOST and FILE are specified by reading a string with - a colon character separating the host from the filename. -USER and PASSWORD are defaulted from the values used when - last ftping from HOST (unless password-remembering is disabled). - Supply a password of the symbol `t' to override this default - (interactively, this is done by giving a prefix arg)" - (interactive - (append (ftp-read-file-name "FTP get host:directory: ") - (list nil (not (null current-prefix-arg))))) - (ftp-find-file-or-directory host file nil user password)) - -(defun ftp-find-file-or-directory (host file filep &optional user password) - "FTP to HOST to get FILE. Third arg is t for file, nil for directory. -Log in as USER with PASSWORD. If USER is nil or PASSWORD is nil or t, -we prompt for the user name and password." - (or (and user password (not (eq password t))) - (progn (setq user (read-ftp-user-password host user (eq password t)) - password (cdr user) - user (car user)))) - (let ((buffer (get-buffer-create (format "*ftp%s %s:%s*" - (if filep "" "-directory") - host file)))) - (set-buffer buffer) - (let ((process nil) - (case-fold-search nil)) - (let ((win nil)) - (unwind-protect - (progn - (setq process (ftp-setup-buffer host file)) - (if (setq win (ftp-login process host user password)) - (message "Logged in") - (error "Ftp login failed"))) - (or win (and process (delete-process process))))) - (message "Opening %s %s:%s..." (if filep "file" "directory") - host file) - (if (ftp-command process - (format "%s \"%s\" -\nquit\n" (if filep "get" "dir") - file) - "\\(150\\|125\\).*\n" - "200.*\n") - (progn (forward-line 1) - (let ((buffer-read-only nil)) - (delete-region (point-min) (point))) - (message "Retrieving %s:%s in background. Bye!" host file) - (set-process-sentinel process - 'ftp-asynchronous-input-sentinel) - process) - (switch-to-buffer buffer) - (let ((buffer-read-only nil)) - (insert-before-markers "<<<Ftp lost>>>")) - (delete-process process) - (error "Ftp %s:%s lost" host file))))) - - -;;;###autoload -(defun ftp-write-file (host file &optional user password) - "FTP to HOST to write FILE, logging in as USER with password PASSWORD. -Interactively, HOST and FILE are specified by reading a string with colon -separating the host from the filename. -USER and PASSWORD are defaulted from the values used when - last ftping from HOST (unless `password-remembering' is disabled). - Supply a password of the symbol `t' to override this default - (interactively, this is done by giving a prefix arg)" - (interactive - (append (ftp-read-file-name "FTP write host:file: ") - (list nil (not (null current-prefix-arg))))) - (or (and user password (not (eq password t))) - (progn (setq user (read-ftp-user-password host user (eq password t)) - password (cdr user) - user (car user)))) - (let ((buffer (get-buffer-create (format "*ftp %s:%s*" host file))) - (tmp (make-temp-name "/tmp/emacsftp"))) - (write-region (point-min) (point-max) tmp) - (save-excursion - (set-buffer buffer) - (make-local-variable 'ftp-temp-file-name) - (setq ftp-temp-file-name tmp) - (let ((process (ftp-setup-buffer host file)) - (case-fold-search nil)) - (let ((win nil)) - (unwind-protect - (if (setq win (ftp-login process host user password)) - (message "Logged in") - (error "Ftp login lost")) - (or win (delete-process process)))) - (message "Opening file %s:%s..." host file) - (if (ftp-command process - (format "send \"%s\" \"%s\"\nquit\n" tmp file) - "\\(150\\|125\\).*\n" - "200.*\n") - (progn (forward-line 1) - (setq foo1 (current-buffer)) - (let ((buffer-read-only nil)) - (delete-region (point-min) (point))) - (message "Saving %s:%s in background. Bye!" host file) - (set-process-sentinel process - 'ftp-asynchronous-output-sentinel) - process) - (switch-to-buffer buffer) - (setq foo2 (current-buffer)) - (let ((buffer-read-only nil)) - (insert-before-markers "<<<Ftp lost>>>")) - (delete-process process) - (error "Ftp write %s:%s lost" host file)))))) - - -(defun ftp-setup-buffer (host file) - (fundamental-mode) - (and (get-buffer-process (current-buffer)) - (progn (discard-input) - (if (y-or-n-p (format "Kill process \"%s\" in %s? " - (process-name (get-buffer-process - (current-buffer))) - (buffer-name (current-buffer)))) - (while (get-buffer-process (current-buffer)) - (kill-process (get-buffer-process (current-buffer)))) - (error "Foo")))) - ;(buffer-disable-undo (current-buffer)) - (setq buffer-read-only nil) - (erase-buffer) - (make-local-variable 'ftp-host) - (setq ftp-host host) - (make-local-variable 'ftp-file) - (setq ftp-file file) - (setq foo3 (current-buffer)) - (setq buffer-read-only t) - (start-process "ftp" (current-buffer) "ftp" "-i" "-n" "-g")) - - -(defun ftp-login (process host user password) - (message "FTP logging in as %s@%s..." user host) - (if (ftp-command process - (format "open %s\nuser %s %s\n" host user password) - "230.*\n" - "\\(Connected to \\|220\\|331\\|Remote system type\\|Using.*mode\\|Remember to set\\).*\n") - t - (switch-to-buffer (process-buffer process)) - (delete-process process) - (if (listp ftp-password-alist) - (setq ftp-password-alist (delq (assoc host ftp-password-alist) - ftp-password-alist))) - nil)) - -(defun ftp-command (process command win ignore) - (process-send-string process command) - (let ((p 1)) - (while (numberp p) - (cond ;((not (bolp))) - ((looking-at "^[0-9]+-") - (while (not (re-search-forward "^[0-9]+ " nil t)) - (save-excursion - (accept-process-output process))) - (beginning-of-line)) - ((looking-at win) - (goto-char (point-max)) - (setq p t)) - ((looking-at "^ftp> \\|^\n") - (goto-char (match-end 0))) - ((looking-at ignore) - ;; Ignore status messages whose codes indicate no problem. - (forward-line 1)) - ((looking-at "^[^0-9]") - ;; Ignore any lines that don't have status codes. - (forward-line 1)) - ((not (search-forward "\n" nil t)) - ;; the way asynchronous process-output works with (point) - ;; is really really disgusting. - (setq p (point)) - (condition-case () - (accept-process-output process) - (error nil)) - (goto-char p)) - (t - (setq p nil)))) - p)) - - -(defun ftp-asynchronous-input-sentinel (process msg) - (ftp-sentinel process msg t t)) -(defun ftp-synchronous-input-sentinel (process msg) - (ftp-sentinel process msg nil t)) -(defun ftp-asynchronous-output-sentinel (process msg) - (ftp-sentinel process msg t nil)) -(defun ftp-synchronous-output-sentinel (process msg) - (ftp-sentinel process msg nil nil)) - -(defun ftp-sentinel (process msg asynchronous input) - (cond ((null (buffer-name (process-buffer process))) - ;; deleted buffer - (set-process-buffer process nil)) - ((and (eq (process-status process) 'exit) - (= (process-exit-status process) 0)) - (save-excursion - (set-buffer (process-buffer process)) - (let (msg - (r (if input "[0-9]+ bytes received in [0-9]+\\.[0-9]+ seconds.*$" "[0-9]+ bytes sent in [0-9]+\\.[0-9]+ seconds.*$"))) - (goto-char (point-max)) - (search-backward "226 ") - (if (looking-at r) - (search-backward "226 ")) - (let ((p (point))) - (setq msg (concat (format "ftp %s %s:%s done" - (if input "read" "write") - ftp-host ftp-file) - (if (re-search-forward r nil t) - (concat ": " (buffer-substring - (match-beginning 0) - (match-end 0))) - ""))) - (delete-region p (point-max)) - (save-excursion - (set-buffer (get-buffer-create "*ftp log*")) - (let ((buffer-read-only nil)) - (insert msg ?\n)))) - ;; Note the preceding let must end here - ;; so it doesn't cross the (kill-buffer (current-buffer)). - (if (not input) - (progn - (condition-case () - (and (boundp 'ftp-temp-file-name) - ftp-temp-file-name - (delete-file ftp-temp-file-name)) - (error nil)) - ;; Kill the temporary buffer which the ftp process - ;; puts its output in. - (kill-buffer (current-buffer))) - ;; You don't want to look at this. - (let ((kludge (generate-new-buffer (format "%s:%s (ftp)" - ftp-host ftp-file)))) - (setq kludge (prog1 (buffer-name kludge) (kill-buffer kludge))) - (rename-buffer kludge) - ;; ok, you can look again now. - (set-buffer-modified-p nil) - (ftp-setup-write-file-hooks))) - (if (and asynchronous - ;(waiting-for-user-input-p) - ) - (progn (message "%s" msg) - (sleep-for 2)))))) - ((memq (process-status process) '(exit signal)) - (save-excursion - (set-buffer (process-buffer process)) - (setq msg (format "Ftp died (buffer %s): %s" - (buffer-name (current-buffer)) - msg)) - (let ((buffer-read-only nil)) - (goto-char (point-max)) - (insert ?\n ?\n msg)) - (delete-process proc) - (set-buffer (get-buffer-create "*ftp log*")) - (let ((buffer-read-only nil)) - (goto-char (point-max)) - (insert msg)) - (if (waiting-for-user-input-p) - (error "%s" msg)))))) - -(defun ftp-setup-write-file-hooks () - (let ((hooks write-file-hooks)) - (make-local-variable 'write-file-hooks) - (setq write-file-hooks (append write-file-hooks - '(ftp-write-file-hook)))) - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'ftp-revert-buffer) - (setq default-directory "/tmp/") - (setq buffer-file-name (concat default-directory - (make-temp-name - (buffer-name (current-buffer))))) - (setq buffer-read-only nil)) - -(defun ftp-write-file-hook () - (let ((process (ftp-write-file ftp-host ftp-file))) - (set-process-sentinel process 'ftp-synchronous-output-sentinel) - (message "FTP writing %s:%s..." ftp-host ftp-file) - (while (eq (process-status process) 'run) - (condition-case () - (accept-process-output process) - (error nil))) - (set-buffer-modified-p nil) - (message "FTP writing %s:%s...done" ftp-host ftp-file)) - t) - -(defun ftp-revert-buffer (&rest ignore) - (let ((process (ftp-find-file ftp-host ftp-file))) - (set-process-sentinel process 'ftp-synchronous-input-sentinel) - (message "FTP reverting %s:%s" ftp-host ftp-file) - (while (eq (process-status process) 'run) - (condition-case () - (accept-process-output process) - (error nil))) - (and (eq (process-status process) 'exit) - (= (process-exit-status process) 0) - (set-buffer-modified-p nil)) - (message "Reverted"))) - -;;; ftp.el ends here
--- a/lisp/=gnus-uu.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3057 +0,0 @@ -;;; gnus-uu.el --- extract, view or save (uu)encoded files from gnus - -;; Copyright (C) 1985, 1986, 1987, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Lars Ingebrigtsen <larsi@ifi.uio.no> -;; Created: 2 Oct 1993 -;; Version: v2.8 -;; Last Modified: 1994/06/01 -;; Keywords: news - -;; 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: - -;; All gnus-uu commands start with `C-c C-v'. -;; -;; Short user manual for this package: -;; -;; Type `C-c C-v C-v' to decode and view all articles of the current -;; series. The defaults should be reasonable for most systems. -;; -;; Type `C-c C-v C-i' to toggle interactive mode. When using -;; interactive mode, gnus-uu will which display a buffer that will let -;; you see the suggested commands to be executed. -;; -;; To post an uuencoded file, type `C-c C-v p', which will enter you -;; into a buffer analogous to the one you will get when typing `a'. Do -;; an `M-x describe-mode' in this buffer to get a description of what -;; this buffer lets you do. -;; -;; Read the documentation of the `gnus-uu' dummy function for a more -;; complete description of what this package does and how you can -;; customize it to fit your needs. -;; -;; -;; -;; History -;; -;; v1.0: First version released Oct 2 1992. -;; -;; v1.1: Changed `C-c C-r' to `C-c C-e' and `C-c C-p' to `C-c C-k'. -;; Changed (setq gnus-exit-group-hook) to (add-hook). Removed -;; checking for "Re:" for finding parts. -;; -;; v2.2: Fixed handling of currupted archives. Changed uudecoding to -;; an asynchronous process to avoid loading tons of data into emacs -;; buffers. No longer reads articles emacs already have aboard. Fixed -;; a firmer support for shar files. Made regexp searches for files -;; more convenient. Added `C-c C-l' for editing uucode begin -;; lines. Added multi-system decoder entry point. Added interactive -;; view mode. Added function for decoding and saving all uuencoded -;; articles in the current newsgroup. -;; -;; v2.3: After suggestions I have changed all the gnus-uu key bindings -;; to avoid hogging all the user keys (C-c LETTER). Also added -;; (provide) and fixed some saving stuff. First posted version to -;; gnu.emacs.sources. -;; -;; v2.4: Fixed some more in the save-all category. Automatic fixing of -;; uucode "begin" lines: names on the form of "dir/file" are -;; translated into "dir-file". Added a function for fixing stripped -;; uucode articles. Added binhex save. -;; -;; v2.5: First version copyrighted by FSF. Changed lots of -;; documentation strings. -;; -;; v2.5.1: Added uuencode/posting code to post binary files. -;; -;; v2.6: Thread support. gnus-uu is now able to decode uuencoded files -;; posted in threads. gnus-uu can also post in threads. I don't know -;; if this ability is of much use - I've never seen anyone post -;; uuencoded files in threads. -;; -;; v2.7: gnus-uu is now able to decode (and view/save) multiple -;; encoded files in one big gulp. Also added pseudo-mime support -;; (users can use metamail to view files), posting uuencoded/mime -;; files and various other bits and pieces. -;; -;; v2.7.1: New functions for decoding/saving threads bound to `C-c -;; C-v C-j'. Handy to save entire threads, not very useful for -;; decoding, as nobody posts encoded files in threads... -;; -;; v2.7.2: New functions for digesting and forwarding articles added -;; on the suggestion of Per Abrahamsen. Also added a function for -;; marking threads. -;; -;; v2.8: Fixed saving original files in interactive mode. Fixed ask -;; before/save after view. Fixed setting up interactive buffers. Added -;; scanning and rescanning from interactive mode. Added the -;; `gnus-uu-ignore-file-by-name' and `...-by-type' variables to allow -;; users to sift files they don't want to view. At the suggestion of -;; boris@cs.rochester.edu, `C-c C-v C-h' has been undefined to allow -;; users to view list of binding beginning with `C-c C-v'. Fixed -;; viewing with `gnus-uu-asynchronous' set. The -;; "decode-and-save/view-all-articles" functions now accepts the -;; numeric prefix to delimit the maximum number of files to be -;; decoded. - -;;; Code: - -(require 'gnus) -(require 'gnuspost) - -;; Binding of keys to the gnus-uu functions. - -(defvar gnus-uu-ctl-map nil) -(define-prefix-command 'gnus-uu-ctl-map) -(define-key gnus-summary-mode-map "\C-c\C-v" gnus-uu-ctl-map) - -(define-key gnus-uu-ctl-map "\C-v" 'gnus-uu-decode-and-view) -(define-key gnus-uu-ctl-map "v" 'gnus-uu-decode-and-save) -(define-key gnus-uu-ctl-map "\C-s" 'gnus-uu-shar-and-view) -(define-key gnus-uu-ctl-map "s" 'gnus-uu-shar-and-save) -(define-key gnus-uu-ctl-map "\C-m" 'gnus-uu-multi-decode-and-view) -(define-key gnus-uu-ctl-map "m" 'gnus-uu-multi-decode-and-save) - -(define-key gnus-uu-ctl-map "\C-b" 'gnus-uu-decode-and-show-in-buffer) - -(define-key gnus-summary-mode-map "#" 'gnus-uu-mark-article) -(define-key gnus-summary-mode-map "\M-#" 'gnus-uu-unmark-article) -(define-key gnus-uu-ctl-map "\C-u" 'gnus-uu-unmark-all-articles) -(define-key gnus-uu-ctl-map "\C-r" 'gnus-uu-mark-by-regexp) -(define-key gnus-uu-ctl-map "r" 'gnus-uu-mark-by-regexp) -(define-key gnus-uu-ctl-map "t" 'gnus-uu-mark-thread) - -(define-key gnus-uu-ctl-map "\M-\C-v" 'gnus-uu-marked-decode-and-view) -(define-key gnus-uu-ctl-map "\M-v" 'gnus-uu-marked-decode-and-save) -(define-key gnus-uu-ctl-map "\M-\C-s" 'gnus-uu-marked-shar-and-view) -(define-key gnus-uu-ctl-map "\M-s" 'gnus-uu-marked-shar-and-save) -(define-key gnus-uu-ctl-map "\M-\C-m" 'gnus-uu-marked-multi-decode-and-view) -(define-key gnus-uu-ctl-map "\M-m" 'gnus-uu-marked-multi-decode-and-save) - -(define-key gnus-uu-ctl-map "f" 'gnus-uu-digest-and-forward) -(define-key gnus-uu-ctl-map "\M-f" 'gnus-uu-marked-digest-and-forward) - -(define-key gnus-uu-ctl-map "\C-i" 'gnus-uu-toggle-interactive-view) -(define-key gnus-uu-ctl-map "\C-t" 'gnus-uu-toggle-any-variable) - -(define-key gnus-uu-ctl-map "\C-l" 'gnus-uu-edit-begin-line) - -(define-key gnus-uu-ctl-map "a" 'gnus-uu-decode-and-save-all-unread-articles) -(define-key gnus-uu-ctl-map "w" 'gnus-uu-decode-and-save-all-articles) -(define-key gnus-uu-ctl-map "\C-a" 'gnus-uu-decode-and-view-all-unread-articles) -(define-key gnus-uu-ctl-map "\C-w" 'gnus-uu-decode-and-view-all-articles) - -(define-key gnus-uu-ctl-map "\C-j" 'gnus-uu-threaded-multi-decode-and-view) -(define-key gnus-uu-ctl-map "j" 'gnus-uu-threaded-multi-decode-and-save) - -(define-key gnus-uu-ctl-map "p" 'gnus-uu-post-news) - -;; Dummy function gnus-uu - -(defun gnus-uu () - "gnus-uu is a package for uudecoding and viewing articles. - - -Keymap overview: - -By default, all gnus-uu keystrokes begin with `C-c C-v'. - -There four decoding commands categories: -All commands for viewing are `C-c C-v C-LETTER'. -All commands for saving are `C-c C-v LETTER'. -All commands for marked viewing are `C-c C-v C-M-LETTER'. -All commands for marked saving are `C-c C-v M-LETTER'. - -\\<gnus-summary-mode-map>\\[gnus-uu-decode-and-view]\tDecode and view articles -\\[gnus-uu-decode-and-save]\tDecode and save articles -\\[gnus-uu-shar-and-view]\tUnshar and view articles -\\[gnus-uu-shar-and-save]\tUnshar and save articles -\\[gnus-uu-multi-decode-and-view]\tChoose a decoding method, decode and view articles -\\[gnus-uu-multi-decode-and-save]\tChoose a decoding method, decode and save articles - -\\[gnus-uu-threaded-multi-decode-and-view]\tDecode a thread and view -\\[gnus-uu-threaded-multi-decode-and-save]\tDecode a thread and save - -\\[gnus-uu-decode-and-show-in-buffer]\tDecode the current article and view the result in a buffer -\\[gnus-uu-edit-begin-line]\tEdit the 'begin' line of an uuencoded article - -\\[gnus-uu-decode-and-save-all-unread-articles]\tDecode and save all unread articles -\\[gnus-uu-decode-and-save-all-articles]\tDecode and save all articles -\\[gnus-uu-decode-and-view-all-unread-articles]\tDecode and view all unread articles -\\[gnus-uu-decode-and-view-all-articles]\tDecode and view all articles - -\\[gnus-uu-digest-and-forward]\tDigest and forward a series of articles -\\[gnus-uu-marked-digest-and-forward]\tDigest and forward all marked articles - -\\[gnus-uu-mark-article]\tMark the current article for decoding -\\[gnus-uu-unmark-article]\tUnmark the current article -\\[gnus-uu-unmark-all-articles]\tUnmark all articles -\\[gnus-uu-mark-by-regexp]\tMark articles for decoding by regexp -\\[gnus-uu-mark-thread]\tMark articles in this thread -\\[gnus-uu-marked-decode-and-view]\tDecode and view marked articles -\\[gnus-uu-marked-decode-and-save]\tDecode and save marked articles -\\[gnus-uu-marked-shar-and-view]\tUnshar and view marked articles -\\[gnus-uu-marked-shar-and-save]\tUnshar and save marked articles -\\[gnus-uu-marked-multi-decode-and-view]\tChoose decoding method, decode and view marked articles -\\[gnus-uu-marked-multi-decode-and-save]\tChoose decoding method, decode and save marked articles - -\\[gnus-uu-toggle-asynchronous]\tToggle asynchronous viewing mode -\\[gnus-uu-toggle-query]\tToggle whether to ask before viewing a file -\\[gnus-uu-toggle-always-ask]\tToggle whether to ask to save a file after viewing -\\[gnus-uu-toggle-kill-carriage-return]\tToggle whether to strip trailing carriage returns -\\[gnus-uu-toggle-interactive-view]\tToggle whether to use interactive viewing mode -\\[gnus-uu-toggle-correct-stripped-articles]\tToggle whether to 'correct' articles -\\[gnus-uu-toggle-view-with-metamail]\tToggle whether to use metamail for viewing -\\[gnus-uu-toggle-any-variable]\tToggle any of the things above - -\\[gnus-uu-post-news]\tPost an uuencoded article - -Function description: - -`gnus-uu-decode-and-view' will try to find all articles in the same -series, uudecode them and view the resulting file(s). - -gnus-uu guesses what articles are in the series according to the -following simplish rule: The subjects must be (nearly) identical, -except for the last two numbers of the line. (Spaces are largely -ignored, however.) - -For example: If you choose a subject called - \"cat.gif (2/3)\" -gnus-uu will find all the articles that matches - \"^cat.gif ([0-9]+/[0-9]+).*$\". - -Subjects that are nonstandard, like - \"cat.gif (2/3) Part 6 of a series\", -will not be properly recognized by any of the automatic viewing -commands, and you have to mark the articles manually with '#'. - -`gnus-uu-decode-and-save' will do the same as -`gnus-uu-decode-and-view', except that it will not display the -resulting file, but save it instead. - -`gnus-uu-shar-and-view' and `gnus-uu-shar-and-save' are the \"shar\" -equivalents to the uudecode functions. Instead of feeding the articles -to uudecode, they are run through /bin/sh. Most shar files can be -viewed and/or saved with the normal uudecode commands, which is much -safer, as no foreign code is run. - -Instead of having windows popping up automatically, it can be handy to -view files interactivly, especially when viewing archives. Use -`gnus-uu-toggle-interactive-mode' to toggle interactive mode. - -`gnus-uu-mark-article' marks an article for later -decoding/unsharing/saving/viewing. The files will be decoded in the -sequence they were marked. To decode the files after you've marked the -articles you are interested in, type the corresponding key strokes as -the normal decoding commands, but put a `M-' in the last -keystroke. For instance, to perform a standard uudecode and view, you -would type `C-c C-v C-v'. To perform a marked uudecode and view, say -`C-v C-v M-C-v'. All the other view and save commands are handled the -same way; marked uudecode and save is then `C-c C-v M-v'. - -`gnus-uu-unmark-article' will remove the mark from a previosly marked -article. - -`gnus-uu-unmark-all-articles' will remove the mark from all marked -articles. - -`gnus-uu-mark-by-regexp' will prompt for a regular expression and mark -all articles matching that regular expression. - -`gnus-uu-mark-thread' will mark all articles downward in the current -thread. - -There's an additional way to reach the decoding functions to make -future expansions easier: `gnus-uu-multi-decode-and-view' and the -corresponding save, marked view and marked save functions. You will be -prompted for a decoding method, like uudecode, shar, binhex or plain -save. Note that methods like binhex and save doesn't have view modes; -even if you issue a view command (`C-c C-v C-m' and \"binhex\"), -gnus-uu will just save the resulting binhex file. - -`gnus-uu-decode-and-show-in-buffer' will decode the current article -and display the results in an emacs buffer. This might be useful if -there's jsut some text in the current article that has been uuencoded -by some perverse poster. - -`gnus-uu-decode-and-save-all-articles' looks at all the articles in -the current newsgroup and tries to uudecode everything it can -find. The user will be prompted for a directory where the resulting -files (if any) will be -saved. `gnus-uu-decode-and-save-unread-articles' does only checks -unread articles. - -`gnus-uu-decode-and-view-all-articles' does the same as the function -above, only viewing files instead of saving them. - -`gnus-uu-edit-begin-line' lets you edit the begin line of an uuencoded -file in the current article. Useful to change a corrupted begin line. - - -When using the view commands, `gnus-uu-decode-and-view' for instance, -gnus-uu will (normally, see below) try to view the file according to -the rules given in `gnus-uu-default-view-rules' and -`gnus-uu-user-view-rules'. If it recognizes the file, it will display -it immediately. If the file is some sort of archive, gnus-uu will -attempt to unpack the archive and see if any of the files in the -archive can be viewed. For instance, if you have a gzipped tar file -\"pics.tar.gz\" containing the files \"pic1.jpg\" and \"pic2.gif\", -gnus-uu will uncompress and detar the main file, and then view the two -pictures. This unpacking process is recursive, so if the archive -contains archives of archives, it'll all be unpacked. - -If the view command doesn't recognise the file type, or can't view it -because you don't have the viewer, or can't view *any* of the files in -the archive, the user will be asked if she wishes to have the file -saved somewhere. Note that if the decoded file is an archive, and -gnus-uu manages to view some of the files in the archive, it won't -tell the user that there were some files that were unviewable. Try -interactive view for a different approach. - - -Note that gnus-uu adds a function to `gnus-exit-group-hook' to clear -the list of marked articles and check for any generated files that -might have escaped deletion if the user typed `C-g' during viewing. - - -`gnus-uu-toggle-asynchronous' toggles the `gnus-uu-asynchronous' -variable. - -`gnus-uu-toggle-query' toggles the `gnus-uu-ask-before-view' -variable. - -`gnus-uu-toggle-always-ask' toggles the `gnus-uu-view-and-save' -variable. - -`gnus-uu-toggle-kill-carriage-return' toggles the -`gnus-uu-kill-carriage-return' variable. - -`gnus-uu-toggle-interactive-view' toggles interactive mode. If it is -turned on, gnus-uu won't view files immediately, but will give you a -buffer with the default commands and files and let you edit the -commands and execute them at leisure. - -`gnus-uu-toggle-correct-stripped-articles' toggles whether to check -and correct uuencoded articles that may have had trailing spaces -stripped by mailers. - -`gnus-uu-toggle-view-with-metamail' toggles whether to skip the -gnus-uu viewing methods and just guess at an content-type based on the -file name suffix and feed it to metamail. - -`gnus-uu-toggle-any-variable' is an interface to the toggle commands -listed above. - - -Customization - - Rule Variables - - gnus-uu uses \"rule\" variables to decide how to view a file. All - these variables are of the form - - (list '(regexp1 command2) - '(regexp2 command2) - ...) - - `gnus-uu-user-view-rules' - This variable is consulted first when viewing files. If you wish - to use, for instance, sox to convert an .au sound file, you could - say something like: - - (setq gnus-uu-user-view-rules - (list '(\"\\\\.au$\" \"sox %s -t .aiff > /dev/audio\"))) - - `gnus-uu-user-view-rules-end' - This variable is consulted if gnus-uu couldn't make any matches - from the user and default view rules. - - `gnus-uu-user-interactive-view-rules' - This is the variable used instead of `gnus-uu-user-view-rules' - when in interactive mode. - - `gnus-uu-user-interactive-view-rules-end' - This variable is used instead of `gnus-uu-user-view-rules-end' - when in interactive mode. - - `gnus-uu-user-archive-rules` - This variable can be used to say what comamnds should be used to - unpack archives. - - - Other Variables - - `gnus-uu-ignore-files-by-name' - Files with name matching this regular expression won't be viewed. - - `gnus-uu-ignore-files-by-type' - Files with a MIME type matching this variable won't be viewed. - Note that gnus-uu tries to guess what type the file is based on - the name. gnus-uu is not a MIME package, so this is slightly - kludgy. - - `gnus-uu-tmp-dir' - Where gnus-uu does its work. - - `gnus-uu-do-not-unpack-archives' - Non-nil means that gnus-uu won't peek inside archives looking for - files to dispay. - - `gnus-uu-view-and-save' - Non-nil means that the user will always be asked to save a file - after viewing it. - - `gnus-uu-asynchronous' - Non-nil means that files will be viewed asynchronously. This can - be useful if you're viewing long .mod files, for instance, which - often takes several minutes. Note, however, that since gnus-uu - doesn't ask, and if you are viewing an archive with lots of - viewable files, you'll get them all up more or less at once, - which can be confusing, to say the least. To get gnus-uu to ask - you before viewing a file, set the `gnus-uu-ask-before-view' - variable. - - `gnus-uu-ask-before-view' - Non-nil means that gnus-uu will ask you before viewing each file - - `gnus-uu-ignore-default-view-rules' - Non-nil means that gnus-uu will ignore the default viewing rules. - - `gnus-uu-ignore-default-archive-rules' - Non-nil means that gnus-uu will ignore the default archive - unpacking commands. - - `gnus-uu-kill-carriage-return' - Non-nil means that gnus-uu will strip all carriage returns from - articles. - - `gnus-uu-unmark-articles-not-decoded' - Non-nil means that gnus-uu will mark articles that were - unsuccessfully decoded as unread. - - `gnus-uu-output-window-height' - This variable says how tall the output buffer window is to be - when using interactive view mode. - - `gnus-uu-correct-stripped-uucode' - Non-nil means that gnus-uu will *try* to fix uuencoded files that - have had traling spaces deleted. - - `gnus-uu-use-interactive-view' - Non-nil means that gnus-uu will use interactive viewing mode. - - `gnus-uu-view-with-metamail' - Non-nil means that gnus-uu will ignore the viewing commands - defined by the rule variables and just fudge a MIME content type - based on the file name. The result will be fed to metamail for - viewing. - - `gnus-uu-save-in-digest' - Non-nil means that gnus-uu, when asked to save without decoding, - will save in digests. If this variable is nil, gnus-uu will just - save everything in a file without any embellishments. The - digesting almost conforms to RFC1153 - no easy way to specify any - meaningful volume and issue numbers were found, so I simply - dropped them. - - `gnus-uu-post-include-before-composing' - Non-nil means that gnus-uu will ask for a file to encode before - you compose the article. If this variable is t, you can either - include an encoded file with \\<gnus-uu-post-reply-mode-map>\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you - post the article. - - `gnus-uu-post-length' - Maximum length of an article. The encoded file will be split - into how many articles it takes to post the entire file. - - `gnus-uu-post-threaded' - Non-nil means that gnus-uu will post the encoded file in a - thread. This may not be smart, as no other decoder I have seen - are able to follow threads when collecting uuencoded - articles. (Well, I have seen one package that does that - - gnus-uu, but somehow, I don't think that counts...) Default is - nil. - - `gnus-uu-post-separate-description' - Non-nil means that the description will be posted in a separate - article. The first article will typically be numbered (0/x). If - this variable is nil, the description the user enters will be - included at the beginning of the first article, which will be - numbered (1/x). Default is t. -" - (interactive) - ) - -;; Default viewing action rules - -(defvar gnus-uu-default-view-rules - (list - '("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "xv") - '("\\.tga$" "tgatoppm %s | xv -") - '("\\.te?xt$\\|\\.doc$\\|read.*me" "xterm -e less") - '("\\.\\(wav\\|aiff\\|hcom\\|u[blw]\\|s[bfw]\\|voc\\|smp\\)$" - "sox -v .5 %s -t .au -u - > /dev/audio") - '("\\.au$" "cat %s > /dev/audio") - '("\\.mod$" "str32") - '("\\.ps$" "ghostview") - '("\\.dvi$" "xdvi") - '("\\.[1-6]$" "xterm -e man -l") - '("\\.html$" "xmosaic") - '("\\.mpe?g$" "mpeg_play") - '("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\)$" "xanim") - '("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" - "gnus-uu-archive")) - - "Default actions to be taken when the user asks to view a file. -To change the behaviour, you can either edit this variable or set -`gnus-uu-user-view-rules' to something useful. - -For example: - -To make gnus-uu use 'xli' to display JPEG and GIF files, put the -following in your .emacs file - - (setq gnus-uu-user-view-rules (list '(\"jpg$\\\\|gif$\" \"xli\"))) - -Both these variables are lists of lists with two string elements. The -first string is a regular expression. If the file name matches this -regular expression, the command in the second string is executed with -the file as an argument. - -If the command string contains \"%s\", the file name will be inserted -at that point in the command string. If there's no \"%s\" in the -command string, the file name will be appended to the command string -before executing. - -There are several user variables to tailor the behaviour of gnus-uu to -your needs. First we have `gnus-uu-user-view-rules', which is the -variable gnus-uu first consults when trying to decide how to view a -file. If this variable contains no matches, gnus-uu examines the -default rule vaiable provided in this package. If gnus-uu finds no -match here, it uses `gnus-uu-user-view-rules-end' to try to make a -match. - -Unless, of course, you are using the interactive view mode. Then -`gnus-uu-user-interactive-view-rules' and -`gnus-uu-user-interactive-view-rules-end' will be used instead.") - -(defvar gnus-uu-user-view-rules nil - "Variable detailing what actions are to be taken to view a file. -See the documentation on the `gnus-uu-default-view-rules' variable for -details.") - -(defvar gnus-uu-user-view-rules-end nil - "Variable saying what actions are to be taken if no rule matched the file name. -See the documentation on the `gnus-uu-default-view-rules' variable for -details.") - -(defvar gnus-uu-user-interactive-view-rules nil - "Variable detailing what actions are to be taken to view a file when using interactive mode. -See the documentation on the `gnus-uu-default-view-rules' variable for -details.") - -(defvar gnus-uu-user-interactive-view-rules-end nil - "Variable saying what actions are to be taken if no rule matched the file name when using interactive mode. -See the documentation on the `gnus-uu-default-view-rules' variable for -details.") - -(defvar gnus-uu-default-interactive-view-rules-begin - (list - '("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed s/\r//g") - '("\\.pas$" "cat %s | sed s/\r//g") - )) - -(defvar gnus-uu-default-interactive-view-rules-end - (list - '(".*" "file"))) - -;; Default unpacking commands - -(defvar gnus-uu-default-archive-rules - (list '("\\.tar$" "tar xf") - '("\\.zip$" "unzip -o") - '("\\.ar$" "ar x") - '("\\.arj$" "unarj x") - '("\\.zoo$" "zoo -e") - '("\\.\\(lzh\\|lha\\)$" "lha x") - '("\\.Z$" "uncompress") - '("\\.gz$" "gunzip") - '("\\.arc$" "arc -x")) - ) - -(defvar gnus-uu-destructive-archivers - (list "uncompress" "gunzip")) - -(defvar gnus-uu-user-archive-rules nil - "A list that can be set to override the default archive unpacking commands. -To use, for instance, 'untar' to unpack tar files and 'zip -x' to -unpack zip files, say the following: - (setq gnus-uu-user-archive-rules - (list '(\"\\\\.tar$\" \"untar\") - '(\"\\\\.zip$\" \"zip -x\")))") - -(defvar gnus-uu-ignore-files-by-name nil - "A regular expression saying what files should not be viewed based on name. -If, for instance, you want gnus-uu to ignore all .au and .wav files, -you could say something like - - (setq gnus-uu-ignore-files-by-name \"\\\\.au$\\\\|\\\\.wav$\") - -Note that this variable can be used in conjunction with the -`gnus-uu-ignore-files-by-type' variable.") - -(defvar gnus-uu-ignore-files-by-type nil - "A regular expression saying what files that shouldn't be viewed, based on MIME file type. -If, for instance, you want gnus-uu to ignore all audio files and all mpegs, -you could say something like - - (setq gnus-uu-ignore-files-by-type \"audio/\\\\|video/mpeg\") - -Note that this variable can be used in conjunction with the -`gnus-uu-ignore-files-by-name' variable.") - -;; Pseudo-MIME support - -(defconst gnus-uu-ext-to-mime-list - (list '("\\.gif$" "image/gif") - '("\\.jpe?g$" "image/jpeg") - '("\\.tiff?$" "image/tiff") - '("\\.xwd$" "image/xwd") - '("\\.pbm$" "image/pbm") - '("\\.pgm$" "image/pgm") - '("\\.ppm$" "image/ppm") - '("\\.xbm$" "image/xbm") - '("\\.pcx$" "image/pcx") - '("\\.tga$" "image/tga") - '("\\.ps$" "image/postscript") - '("\\.fli$" "video/fli") - '("\\.wav$" "audio/wav") - '("\\.aiff$" "audio/aiff") - '("\\.hcom$" "audio/hcom") - '("\\.voc$" "audio/voc") - '("\\.smp$" "audio/smp") - '("\\.mod$" "audio/mod") - '("\\.dvi$" "image/dvi") - '("\\.mpe?g$" "video/mpeg") - '("\\.au$" "audio/basic") - '("\\.\\(te?xt\\|doc\\|c\\|h\\)$" "text/plain") - '("\\.\\(c\\|h\\)$" "text/source") - '("read.*me" "text/plain") - '("\\.html$" "text/html") - '("\\.bat$" "text/bat") - '("\\.[1-6]$" "text/man") - '("\\.flc$" "video/flc") - '("\\.rle$" "video/rle") - '("\\.pfx$" "video/pfx") - '("\\.avi$" "video/avi") - '("\\.sme$" "video/sme") - '("\\.rpza$" "video/prza") - '("\\.dl$" "video/dl") - '("\\.qt$" "video/qt") - '("\\.rsrc$" "video/rsrc") - '("\\..*$" "unknown/unknown"))) - -;; Various variables users may set - -(defvar gnus-uu-tmp-dir "/tmp/" - "Variable saying where gnus-uu is to do its work. -Default is \"/tmp/\".") - -(defvar gnus-uu-do-not-unpack-archives nil - "Non-nil means that gnus-uu won't peek inside archives looking for files to dispay. -Default is nil.") - -(defvar gnus-uu-view-and-save nil - "Non-nil means that the user will always be asked to save a file after viewing it. -If the variable is nil, the suer will only be asked to save if the -viewing is unsuccessful. Default is nil.") - -(defvar gnus-uu-asynchronous nil - "Non-nil means that files will be viewed asynchronously. -Default is nil.") - -(defvar gnus-uu-ask-before-view nil - "Non-nil means that gnus-uu will ask you before viewing each file. -Especially useful when `gnus-uu-asynchronous' is set. Default is -nil.") - -(defvar gnus-uu-ignore-default-view-rules nil - "Non-nil means that gnus-uu will ignore the default viewing rules. -Only the user viewing rules will be consulted. Default is nil.") - -(defvar gnus-uu-ignore-default-archive-rules nil - "Non-nil means that gnus-uu will ignore the default archive unpacking commands. -Only the user unpacking commands will be consulted. Default is nil.") - -(defvar gnus-uu-kill-carriage-return t - "Non-nil means that gnus-uu will strip all carriage returns from articles. -Default is t.") - -(defvar gnus-uu-view-with-metamail nil - "Non-nil means that files will be viewed with metamail. -The gnus-uu viewing functions will be ignored and gnus-uu will try -to guess at a content-type based on file name suffixes. Default -it nil.") - -(defvar gnus-uu-unmark-articles-not-decoded nil - "Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread. -Default is nil.") - -(defvar gnus-uu-output-window-height 20 - "This variable says how tall the output buffer window is to be when using interactive view mode. -Change it at your convenience. Default is 20.") - -(defvar gnus-uu-correct-stripped-uucode nil - "Non-nil means that gnus-uu will *try* to fix uuencoded files that have had traling spaces deleted. -Default is nil.") - -(defvar gnus-uu-use-interactive-view nil - "Non-nil means that gnus-uu will use interactive viewing mode. -Gnus-uu will create a special buffer where the user may choose -interactively which files to view and how. Default is nil.") - -(defvar gnus-uu-save-in-digest nil - "Non-nil means that gnus-uu, when asked to save without decoding, will save in digests. -If this variable is nil, gnus-uu will just save everything in a -file without any embellishments. The digesting almost conforms to RFC1153 - -no easy way to specify any meaningful volume and issue numbers were found, -so I simply dropped them.") - - -;; Internal variables - -(defconst gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") -(defconst gnus-uu-end-string "^end[ \t]*$") - -(defconst gnus-uu-body-line "^M") -(let ((i 61)) - (while (> (setq i (1- i)) 0) - (setq gnus-uu-body-line (concat gnus-uu-body-line "[^a-z]"))) - (setq gnus-uu-body-line (concat gnus-uu-body-line ".?$"))) - -;"^M.............................................................?$" - -(defconst gnus-uu-shar-begin-string "^#! */bin/sh") - -(defvar gnus-uu-shar-file-name nil) -(defconst gnus-uu-shar-name-marker "begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)") -(defvar gnus-uu-shar-directory nil) - -(defvar gnus-uu-file-name nil) -(defvar gnus-uu-list-of-files-decoded nil) -(defconst gnus-uu-uudecode-process nil) - -(defvar gnus-uu-interactive-file-list nil) -(defvar gnus-uu-marked-article-list nil) -(defvar gnus-uu-generated-file-list nil) -(defvar gnus-uu-work-dir nil) - -(defconst gnus-uu-interactive-buffer-name "*gnus-uu interactive*") -(defconst gnus-uu-output-buffer-name "*Gnus UU Output*") -(defconst gnus-uu-result-buffer "*Gnus UU Result Buffer*") - -(defconst gnus-uu-highest-article-number 1) - -;; Interactive functions - -;; UUdecode and view - -(defun gnus-uu-decode-and-view () - "UUdecodes and 'views' (if possible) the resulting file. -'Viewing' can be any action at all, as defined in the -`gnus-uu-file-action-list' variable. Running 'xv' on gifs and 'cat ->/dev/audio' on au files are popular actions. If the file can't be -viewed, the user is asked if she would like to save the file instead." - (interactive) - (gnus-uu-decode-and-view-or-save t nil)) - -(defun gnus-uu-decode-and-save () - "Decodes and saves the resulting file." - (interactive) - (gnus-uu-decode-and-view-or-save nil nil)) - -(defun gnus-uu-marked-decode-and-view () - "Decodes and views articles marked. -The marked equivalent to `gnus-uu-decode-and-view'." - (interactive) - (gnus-uu-decode-and-view-or-save t t)) - -(defun gnus-uu-marked-decode-and-save () - "Decodes and saves articles marked. -The marked equivalent to `gnus-uu-decode-and-save'." - (interactive) - (gnus-uu-decode-and-view-or-save nil t)) - - -;; Unshar and view - -(defun gnus-uu-shar-and-view () - "Unshars and views articles. -The shar equivalent of `gnus-uu-decode-and-view'." - (interactive) - (gnus-uu-unshar-and-view-or-save t nil)) - -(defun gnus-uu-shar-and-save () - "Unshars and saves files. -The shar equivalent to `gnus-uu-decode-and-save'." - (interactive) - (gnus-uu-unshar-and-view-or-save nil nil)) - -(defun gnus-uu-marked-shar-and-view () - "Unshars and views articles marked. -The marked equivalent to `gnus-uu-shar-and-view'." - (interactive) - (gnus-uu-unshar-and-view-or-save t t)) - -(defun gnus-uu-marked-shar-and-save () - "Unshars and saves articles marked. -The marked equivalent to `gnus-uu-shar-and-save'." - (interactive) - (gnus-uu-unshar-and-view-or-save nil t)) - -;; Threaded decode - -(defun gnus-uu-threaded-decode-and-view () - "Decodes and saves the resulting file." - (interactive) - (gnus-uu-threaded-decode-and-view-or-save t)) - -(defun gnus-uu-threaded-decode-and-save () - "Decodes and saves the resulting file." - (interactive) - (gnus-uu-threaded-decode-and-view-or-save nil)) - -(defun gnus-uu-threaded-multi-decode-and-view () - "Decodes and saves the resulting file." - (interactive) - (gnus-uu-threaded-multi-decode-and-view-or-save t)) - -(defun gnus-uu-threaded-multi-decode-and-save () - "Decodes and saves the resulting file." - (interactive) - (gnus-uu-threaded-multi-decode-and-view-or-save nil)) - -(defun gnus-uu-threaded-decode-and-view-or-save (&optional view) - (gnus-uu-unmark-all-articles) - (gnus-uu-mark-thread) - (gnus-uu-decode-and-view-or-save view t)) - -(defun gnus-uu-threaded-multi-decode-and-view-or-save (view) - (let (type) - (message "Decode type: [u]udecode, (s)har, s(a)ve, (b)inhex: ") - (setq type (read-char)) - (if (not (or (= type ?u) (= type ?s) (= type ?b) (= type ?a))) - (error "No such decoding method '%c'" type)) - - (gnus-uu-unmark-all-articles) - (gnus-uu-mark-thread) - - (if (= type ?\r) (setq type ?u)) - (cond ((= type ?u) (gnus-uu-decode-and-view-or-save view t)) - ((= type ?s) (gnus-uu-unshar-and-view-or-save view t)) - ((= type ?b) (gnus-uu-binhex-and-save view t)) - ((= type ?a) (gnus-uu-save-articles view t))))) - - -;; Toggle commands - -(defun gnus-uu-toggle-asynchronous () - "This function toggles asynchronous viewing." - (interactive) - (if (setq gnus-uu-asynchronous (not gnus-uu-asynchronous)) - (message "gnus-uu will now view files asynchronously") - (message "gnus-uu will now view files synchronously"))) - -(defun gnus-uu-toggle-query () - "This function toggles whether to ask before viewing or not." - (interactive) - (if (setq gnus-uu-ask-before-view (not gnus-uu-ask-before-view)) - (message "gnus-uu will now ask before viewing") - (message "gnus-uu will now view without asking first"))) - -(defun gnus-uu-toggle-always-ask () - "This function toggles whether to always ask to save a file after viewing." - (interactive) - (if (setq gnus-uu-view-and-save (not gnus-uu-view-and-save)) - (message "gnus-uu will now ask to save the file after viewing") - (message "gnus-uu will now not ask to save after successful viewing"))) - -(defun gnus-uu-toggle-interactive-view () - "This function toggles whether to use interactive view." - (interactive) - (if (setq gnus-uu-use-interactive-view (not gnus-uu-use-interactive-view)) - (message "gnus-uu will now use interactive view") - (message "gnus-uu will now use non-interactive view"))) - -(defun gnus-uu-toggle-unmark-undecoded () - "This function toggles whether to unmark articles not decoded." - (interactive) - (if (setq gnus-uu-unmark-articles-not-decoded - (not gnus-uu-unmark-articles-not-decoded)) - (message "gnus-uu will now unmark articles not decoded") - (message "gnus-uu will now not unmark articles not decoded"))) - -(defun gnus-uu-toggle-kill-carriage-return () - "This function toggles the stripping of carriage returns from the articles." - (interactive) - (if (setq gnus-uu-kill-carriage-return (not gnus-uu-kill-carriage-return)) - (message "gnus-uu will now strip carriage returns") - (message "gnus-uu won't strip carriage returns"))) - -(defun gnus-uu-toggle-view-with-metamail () - "This function toggles whether to view files with metamail." - (interactive) - (if (setq gnus-uu-view-with-metamail (not gnus-uu-view-with-metamail)) - (message "gnus-uu will now view with metamail") - (message "gnus-uu will now view with the gnus-uu viewing functions"))) - -(defun gnus-uu-toggle-correct-stripped-uucode () - "This function toggles whether to correct stripped uucode." - (interactive) - (if (setq gnus-uu-correct-stripped-uucode - (not gnus-uu-correct-stripped-uucode)) - (message "gnus-uu will now correct stripped uucode") - (message "gnus-uu won't check and correct stripped uucode"))) - -(defun gnus-uu-toggle-any-variable () - "This function ask what variable the user wants to toggle." - (interactive) - (let (rep) - (message "(a)sync, (q)uery, (p)ask, (k)ill CR, (i)nteract, (u)nmark, (c)orrect, (m)eta") - (setq rep (read-char)) - (if (= rep ?a) - (gnus-uu-toggle-asynchronous)) - (if (= rep ?q) - (gnus-uu-toggle-query)) - (if (= rep ?p) - (gnus-uu-toggle-always-ask)) - (if (= rep ?k) - (gnus-uu-toggle-kill-carriage-return)) - (if (= rep ?u) - (gnus-uu-toggle-unmark-undecoded)) - (if (= rep ?c) - (gnus-uu-toggle-correct-stripped-uucode)) - (if (= rep ?m) - (gnus-uu-toggle-view-with-metamail)) - (if (= rep ?i) - (gnus-uu-toggle-interactive-view)))) - - -;; Misc interactive functions - -(defun gnus-uu-decode-and-show-in-buffer () - "Uudecodes the current article and displays the result in a buffer. -Might be useful if someone has, for instance, some text uuencoded in -their sigs. (Stranger things have happened.)" - (interactive) - (gnus-uu-initialize) - (let ((uu-buffer (get-buffer-create gnus-uu-output-buffer-name)) - file-name) - (save-excursion - (and - (gnus-summary-select-article) - (gnus-uu-grab-articles (list gnus-current-article) - 'gnus-uu-uustrip-article-as) - (setq file-name (concat gnus-uu-work-dir gnus-uu-file-name)) - (progn - (save-excursion - (set-buffer uu-buffer) - (erase-buffer) - (insert-file-contents file-name)) - (set-window-buffer (get-buffer-window gnus-article-buffer) - uu-buffer) - (message "Showing file %s in buffer" file-name) - (delete-file file-name)))))) - -(defun gnus-uu-edit-begin-line () - "Edit the begin line of the current article." - (interactive) - (let ((buffer-read-only nil) - begin b) - (save-excursion - (gnus-summary-select-article) - (set-buffer gnus-article-buffer) - (goto-line 1) - (if (not (re-search-forward "begin " nil t)) - (error "No begin line in the current article") - (beginning-of-line) - (setq b (point)) - (end-of-line) - (setq begin (buffer-substring b (point))) - (setq begin (read-string "" begin)) - (setq buffer-read-only nil) - (delete-region b (point)) - (insert-string begin))))) - - -;; Multi functions - -(defun gnus-uu-multi-decode-and-view () - "Choose a method of decoding and then decode and view. -This function lets the user decide what method to use for decoding. -Other than that, it's equivalent to the other decode-and-view -functions." - (interactive) - (gnus-uu-multi-decode-and-view-or-save t nil)) - -(defun gnus-uu-multi-decode-and-save () - "Choose a method of decoding and then decode and save. -This function lets the user decide what method to use for decoding. -Other than that, it's equivalent to the other decode-and-save -functions." - (interactive) - (gnus-uu-multi-decode-and-view-or-save nil nil)) - -(defun gnus-uu-marked-multi-decode-and-view () - "Choose a method of decoding and then decode and view the marked articles. -This function lets the user decide what method to use for decoding. -Other than that, it's equivalent to the other marked decode-and-view -functions." - (interactive) - (gnus-uu-multi-decode-and-view-or-save t t)) - -(defun gnus-uu-marked-multi-decode-and-save () - "Choose a method of decoding and then decode and save the marked articles. -This function lets the user decide what method to use for decoding. -Other than that, it's equivalent to the other marked decode-and-save -functions." - (interactive) - (gnus-uu-multi-decode-and-view-or-save t t)) - -(defun gnus-uu-multi-decode-and-view-or-save (view marked) - (let (type) - (message "[u]udecode, (s)har, s(a)ve, (b)inhex: ") - (setq type (read-char)) - (if (= type ?\r) (setq type ?u)) - (cond ((= type ?u) (gnus-uu-decode-and-view-or-save view marked)) - ((= type ?s) (gnus-uu-unshar-and-view-or-save view marked)) - ((= type ?b) (gnus-uu-binhex-and-save view marked)) - ((= type ?a) (gnus-uu-save-articles view marked)) - (t (error "Unknown decode method '%c'." type))))) - - -;; "All articles" commands - -(defconst gnus-uu-rest-of-articles nil) -(defvar gnus-uu-current-save-dir nil) - -(defun gnus-uu-decode-and-view-all-articles (arg &optional unread) - "Try to decode all articles and view the result. -ARG delimits the number of files to be decoded." - (interactive "p") - (if (not (setq gnus-uu-marked-article-list - (nreverse (gnus-uu-get-list-of-articles - "^." nil unread t)))) - (error "No%s articles to be decoded" (if unread " unread" ""))) - (gnus-uu-decode-and-view-or-save t t nil (if (> arg 1) arg nil))) - -(defun gnus-uu-decode-and-view-all-unread-articles (arg) - "Try to decode all unread articles and view the result. -ARG delimits the number of files to be decoded." - (interactive "p") - (gnus-uu-decode-and-view-all-articles arg t)) - -(defun gnus-uu-decode-and-save-all-unread-articles (arg) - "Try to decode all unread articles and saves the result. -This function reads all unread articles in the current group and sees -whether it can uudecode the articles. The user will be prompted for an -directory to put the resulting (if any) files. -ARG delimits the number of files to be decoded." - (interactive "p") - (gnus-uu-decode-and-save-articles arg t t)) - -(defun gnus-uu-decode-and-save-all-articles (arg) - "Try to decode all articles and saves the result. -Does the same as `gnus-uu-decode-and-save-all-unread-articles', except -that it grabs all articles visible, unread or not. -ARG delimits the number of files to be decoded." - (interactive "p") - (gnus-uu-decode-and-save-articles arg nil t)) - -(defun gnus-uu-decode-and-save-articles (arg &optional unread unmark) - (let (dir) - (if (not (setq gnus-uu-marked-article-list - (nreverse (gnus-uu-get-list-of-articles - "^." nil unread t)))) - (error "No%s articles to be decoded." (if unread " unread" "")) - (setq dir (gnus-uu-read-directory "Where do you want the files? ")) - (gnus-uu-decode-and-view-or-save nil t dir (if (> arg 1) arg nil)) - (message "Saved.")))) - - -;; Work functions - -; All the interactive uudecode/view/save/marked functions are interfaces -; to this function, which does the rest. -(defun gnus-uu-decode-and-view-or-save (view marked &optional save-dir limit) - (gnus-uu-initialize) - (let (decoded) - (save-excursion - (if (gnus-uu-decode-and-strip nil marked limit) - (progn - (setq decoded t) - (if view - (gnus-uu-view-directory gnus-uu-work-dir - gnus-uu-use-interactive-view) - (gnus-uu-save-directory gnus-uu-work-dir save-dir save-dir) - (gnus-uu-check-for-generated-files))))) - - (gnus-uu-summary-next-subject) - - (if (and gnus-uu-use-interactive-view view decoded) - (gnus-uu-do-interactive)) - - (if (or (not view) (not gnus-uu-use-interactive-view) (not decoded)) - (gnus-uu-clean-up)))) - -; Unshars and views/saves marked/unmarked articles. -(defun gnus-uu-unshar-and-view-or-save (view marked) - (gnus-uu-initialize) - (let (tar-file files decoded) - (save-excursion - (setq gnus-uu-shar-directory - (make-temp-name (concat gnus-uu-tmp-dir "gnusuush"))) - (make-directory gnus-uu-shar-directory) - (gnus-uu-add-file gnus-uu-shar-directory) - (if (gnus-uu-decode-and-strip t marked) - (progn - (setq decoded t) - (setq files (directory-files gnus-uu-shar-directory t)) - (setq gnus-uu-generated-file-list - (append files gnus-uu-generated-file-list)) - (if (> (length files) 3) - (progn - (setq tar-file - (concat - (make-temp-name (concat gnus-uu-tmp-dir "gnusuuar")) - ".tar")) - (gnus-uu-add-file tar-file) - (call-process - "sh" nil - (get-buffer-create gnus-uu-output-buffer-name) nil "-c" - (format "cd %s ; tar cf %s * ; cd .. ; rm -r %s" - gnus-uu-shar-directory tar-file - gnus-uu-shar-directory)) - (if view - (gnus-uu-view-file tar-file) - (gnus-uu-save-file tar-file))) - (if view - (gnus-uu-view-file (elt files 2)) - (gnus-uu-save-file (elt files 2))))))) - - (gnus-uu-summary-next-subject) - - (if (and gnus-uu-use-interactive-view view decoded) - (gnus-uu-do-interactive)) - - (if (or (not gnus-uu-use-interactive-view) (not decoded)) - (gnus-uu-clean-up)))) - - -;; Functions for saving and possibly digesting articles without -;; any decoding. - -(defconst gnus-uu-saved-article-name nil) - -; VIEW isn't used, but is here anyway, to provide similar interface to -; the other related functions. If MARKED is non-nil, the list of -; marked articles is used. If NO-SAVE is non-nil, the articles aren't -; actually saved in a permanent location, but the collecting is done -; and a temporary file with the result is returned. -(defun gnus-uu-save-articles (view marked &optional no-save) - (let (list-of-articles) - (save-excursion - (gnus-uu-initialize) - (if (not marked) - (setq list-of-articles (gnus-uu-get-list-of-articles)) - (setq list-of-articles (reverse gnus-uu-marked-article-list)) - (setq gnus-uu-marked-article-list nil)) - - (if (not list-of-articles) - (error "No list of articles")) - - (setq gnus-uu-saved-article-name - (concat gnus-uu-work-dir - (if no-save - gnus-newsgroup-name - (read-file-name "Enter file name: " gnus-newsgroup-name - gnus-newsgroup-name)))) - (gnus-uu-add-file gnus-uu-saved-article-name) - (if (and (gnus-uu-grab-articles list-of-articles 'gnus-uu-save-article t) - (not no-save)) - (gnus-uu-save-file gnus-uu-saved-article-name) - gnus-uu-saved-article-name)))) - -; Function called by gnus-uu-grab-articles to treat each article. -(defun gnus-uu-save-article (buffer in-state) - (if (not gnus-uu-save-in-digest) - (save-excursion - (set-buffer buffer) - (write-region 1 (point-max) gnus-uu-saved-article-name t) - (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) - ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name 'begin 'end)) - ((eq in-state 'last) (list 'end)) - (t (list 'middle)))) - (let (beg subj name headers headline sorthead body end-string state) - (string-match "/\\([^/]*\\)$" gnus-uu-saved-article-name) - (setq name (substring gnus-uu-saved-article-name (match-beginning 1) - (match-end 1))) - (if (or (eq in-state 'first) - (eq in-state 'first-and-last)) - (progn - (setq state (list 'begin)) - (save-excursion (set-buffer (get-buffer-create "*gnus-uu-body*")) - (erase-buffer)) - (save-excursion - (set-buffer (get-buffer-create "*gnus-uu-pre*")) - (erase-buffer) - (insert (format - "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n" - (current-time-string) name name)))) - (if (not (eq in-state 'end)) - (setq state (list 'middle)))) - (save-excursion - (set-buffer (get-buffer "*gnus-uu-body*")) - (goto-char (setq beg (point-max))) - (save-excursion - (save-restriction - (set-buffer buffer) - (goto-char 1) - (re-search-forward "\n\n") - (setq body (buffer-substring (1- (point)) (point-max))) - (narrow-to-region 1 (point)) - (setq headers (list "Date:" "From:" "To:" "Cc:" "Subject:" - "Message-ID:" "Keywords:" "Summary:")) - (while headers - (setq headline (car headers)) - (setq headers (cdr headers)) - (goto-char 1) - (if (re-search-forward (concat "^" headline ".*$") nil t) - (setq sorthead - (concat sorthead (buffer-substring - (match-beginning 0) - (match-end 0)) "\n")))) - (widen))) - (insert sorthead)(goto-char (point-max)) - (insert body)(goto-char (point-max)) - (insert (concat "\n" (make-string 30 ?-) "\n\n")) - (goto-char beg) - (if (re-search-forward "^Subject: \\(.*\\)$" nil t) - (progn - (setq subj (buffer-substring (match-beginning 1) (match-end 1))) - (save-excursion - (set-buffer (get-buffer "*gnus-uu-pre*")) - (insert (format " %s\n" subj)))))) - (if (or (eq in-state 'last) - (eq in-state 'first-and-last)) - (progn - (save-excursion - (set-buffer (get-buffer "*gnus-uu-pre*")) - (insert (format "\n\n%s\n\n" (make-string 70 ?-))) - (write-region 1 (point-max) gnus-uu-saved-article-name)) - (save-excursion - (set-buffer (get-buffer "*gnus-uu-body*")) - (goto-char (point-max)) - (insert - (concat (setq end-string (format "End of %s Digest" name)) - "\n")) - (insert (concat (make-string (length end-string) ?*) "\n")) - (write-region 1 (point-max) gnus-uu-saved-article-name t)) - (kill-buffer (get-buffer "*gnus-uu-pre*")) - (kill-buffer (get-buffer "*gnus-uu-body*")) - (setq state (cons 'end state)))) - (if (memq 'begin state) - (cons gnus-uu-saved-article-name state) - state)))) - - -;; Digest and forward articles - -(autoload 'gnus-mail-forward-using-mail "gnusmail" - "Forward the current message to another user." t) -(autoload 'gnus-mail-forward-using-mhe "gnusmail" - "Forward the current message to another user." t) - -(defun gnus-uu-digest-and-forward (&optional marked) - "Digests and forwards all articles in this series." - (interactive) - (let ((gnus-uu-save-in-digest t) - file buf) - (setq file (gnus-uu-save-articles nil marked t)) - (switch-to-buffer (setq buf (get-buffer-create "*gnus-uu-forward*"))) - (erase-buffer) - (delete-other-windows) - (erase-buffer) - (insert-file file) - (goto-char 1) - (bury-buffer buf) - (funcall gnus-mail-forward-method))) - -(defun gnus-uu-marked-digest-and-forward (&optional marked) - "Digests and forwards all marked articles." - (interactive) - (gnus-uu-digest-and-forward t)) - - -;; Binhex treatment - not very advanced. - -(defconst gnus-uu-binhex-body-line - "^[^:]...............................................................$") -(defconst gnus-uu-binhex-begin-line - "^:...............................................................$") -(defconst gnus-uu-binhex-end-line - ":$") -(defvar gnus-uu-binhex-article-name nil) - -; This just concatenates and strips stuff from binhexed articles. -; No actual unbinhexing takes place. VIEW is ignored. -(defun gnus-uu-binhex-and-save (view marked) - (gnus-uu-initialize) - (let (list-of-articles) - (save-excursion - (if (not marked) - (setq list-of-articles (gnus-uu-get-list-of-articles)) - (setq list-of-articles (reverse gnus-uu-marked-article-list)) - (setq gnus-uu-marked-article-list nil)) - (if (not list-of-articles) - (error "No list of articles")) - - (setq gnus-uu-binhex-article-name - (concat gnus-uu-work-dir - (read-file-name "Enter binhex file name: " - gnus-newsgroup-name - gnus-newsgroup-name))) - (gnus-uu-add-file gnus-uu-binhex-article-name) - (if (gnus-uu-grab-articles list-of-articles 'gnus-uu-binhex-article t) - (gnus-uu-save-file gnus-uu-binhex-article-name)))) - (gnus-uu-check-for-generated-files) - (gnus-uu-summary-next-subject)) - -(defun gnus-uu-binhex-article (buffer in-state) - (let (state start-char) - (save-excursion - (set-buffer buffer) - (widen) - (goto-char 1) - (if (not (re-search-forward gnus-uu-binhex-begin-line nil t)) - (if (not (re-search-forward gnus-uu-binhex-body-line nil t)) - (setq state (list 'wrong-type)))) - - (if (memq 'wrong-type state) - () - (beginning-of-line) - (setq start-char (point)) - (if (looking-at gnus-uu-binhex-begin-line) - (progn - (setq state (list 'begin)) - (write-region 1 1 gnus-uu-binhex-article-name)) - (setq state (list 'middle))) - (goto-char (point-max)) - (re-search-backward (concat gnus-uu-binhex-body-line "\\|" - gnus-uu-binhex-end-line) nil t) - (if (looking-at gnus-uu-binhex-end-line) - (setq state (if (memq 'begin state) - (cons 'end state) - (list 'end)))) - (beginning-of-line) - (forward-line 1) - (if (file-exists-p gnus-uu-binhex-article-name) - (append-to-file start-char (point) gnus-uu-binhex-article-name)))) - (if (memq 'begin state) - (cons gnus-uu-binhex-article-name state) - state))) - - -;; Internal view commands - -; This function takes two parameters. The first is name of the file to -; be viewed. `gnus-uu-view-file' will look for an action associated -; with the file type of the file. If it finds an appropriate action, -; the file will be attempted displayed. -; -; The second parameter specifies if the user is to be asked whether to -; save the file if viewing is unsuccessful. t means "do not ask." -; -; Note that the file given will be deleted by this function, one way -; or another. If `gnus-uu-asynchronous' is set, it won't be deleted -; right away, but sometime later. If the user is offered to save the -; file, it'll be moved to wherever the user wants it. - -; `gnus-uu-view-file' returns t if viewing is successful. - -(defun gnus-uu-view-file (file &optional silent) - (let (action did-view) - (cond - ((not (setq action (gnus-uu-get-action file))) - (if (and (not silent) (not gnus-uu-use-interactive-view)) - (progn - (message "Couldn't find any rule for file '%s'" file) - (sleep-for 2) - (gnus-uu-ask-to-save-file file)))) - - ((and gnus-uu-use-interactive-view - (not (string= (or action "") "gnus-uu-archive"))) - (gnus-uu-enter-interactive-file (or action "") file)) - - (gnus-uu-ask-before-view - (if (y-or-n-p (format "Do you want to view %s? " file)) - (setq did-view (gnus-uu-call-file-action file action))) - (message "")) - - ((setq did-view (gnus-uu-call-file-action file action))) - - ((not silent) - (gnus-uu-ask-to-save-file file))) - - (if (and (file-exists-p file) - (not gnus-uu-use-interactive-view) - (or - (not (and gnus-uu-asynchronous did-view)) - (string= (or action "") "gnus-uu-archive"))) - (delete-file file)) - - did-view)) - -(defun gnus-uu-call-file-action (file action) - (prog1 - (if gnus-uu-asynchronous - (gnus-uu-call-asynchronous file action) - (gnus-uu-call-synchronous file action)) - (if gnus-uu-view-and-save - (gnus-uu-ask-to-save-file file)))) - -(defun gnus-uu-ask-to-save-file (file) - (if (y-or-n-p (format "Do you want to save the file %s? " file)) - (gnus-uu-save-file file)) - (message "")) - -(defun gnus-uu-get-action (file-name) - (let (action) - (setq action - (gnus-uu-choose-action - file-name - (append - (if (and gnus-uu-use-interactive-view - gnus-uu-user-interactive-view-rules) - gnus-uu-user-interactive-view-rules - gnus-uu-user-view-rules) - (if (or gnus-uu-ignore-default-view-rules - (not gnus-uu-use-interactive-view)) - () - gnus-uu-default-interactive-view-rules-begin) - (if gnus-uu-ignore-default-view-rules - nil - gnus-uu-default-view-rules) - (if gnus-uu-use-interactive-view - (append gnus-uu-user-interactive-view-rules-end - (if gnus-uu-ignore-default-view-rules - () - gnus-uu-default-interactive-view-rules-end)) - gnus-uu-user-view-rules-end)))) - (if (and (not (string= (or action "") "gnus-uu-archive")) - gnus-uu-view-with-metamail) - (if (setq action - (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list)) - (setq action (format "metamail -d -b -c \"%s\"" action)))) - action)) - -; `gnus-uu-call-synchronous' takes two parameters: The name of the -; file to be displayed and the command to display it with. Returns t -; on success and nil if the file couldn't be displayed. -(defun gnus-uu-call-synchronous (file-name action) - (let (did-view command) - (save-excursion - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) - (erase-buffer) - (setq command (gnus-uu-command action file-name)) - (message "Viewing with '%s'" command) - (if (not (= 0 (call-process "sh" nil t nil "-c" command))) - (progn - (goto-char 1) - (while (re-search-forward "\n" nil t) - (replace-match " ")) - (message (concat "Error: " (buffer-substring 1 (point-max)))) - (sit-for 2)) - (message "") - (setq did-view t))) - did-view)) - -; `gnus-uu-call-asyncronous' takes two parameters: The name of the -; file to be displayed and the command to display it with. Since the -; view command is executed asynchronously, it's kinda hard to decide -; whether the command succeded or not, so this function always returns -; t. It also adds "; rm -f file-name" to the end of the execution -; string, so the file will be removed after viewing has ended. -(defun gnus-uu-call-asynchronous (file-name action) - (let (command file tmp-file start) - (while (string-match "/" file-name start) - (setq start (1+ (match-beginning 0)))) - (setq file (substring file-name start)) - (setq tmp-file (concat gnus-uu-work-dir file)) - (if (string= tmp-file file-name) - () - (rename-file file-name tmp-file t) - (setq file-name tmp-file)) - - (setq command (gnus-uu-command action file-name)) - (setq command (format "%s ; rm -f %s" command file-name)) - (message "Viewing with %s" command) - (start-process "gnus-uu-view" nil "sh" "-c" command) - t)) - -; `gnus-uu-decode-and-strip' does all the main work. It finds out what -; articles to grab, grabs them, strips the result and decodes. If any -; of these operations fail, it returns nil, t otherwise. If shar is -; t, it will pass this on to `gnus-uu-grab-articles', which will -; (probably) unshar the articles. If use-marked is non-nil, it won't -; try to find articles, but use the marked list. -(defun gnus-uu-decode-and-strip (&optional shar use-marked limit) - (let (list-of-articles) - (save-excursion - - (if use-marked - (if (not gnus-uu-marked-article-list) - (message "No articles marked") - (setq list-of-articles (reverse gnus-uu-marked-article-list)) - (setq gnus-uu-marked-article-list nil)) - (setq list-of-articles (gnus-uu-get-list-of-articles))) - - (and list-of-articles - (gnus-uu-grab-articles - list-of-articles - (if shar 'gnus-uu-unshar-article 'gnus-uu-uustrip-article-as) - t limit))))) - -; Takes a string and puts a \ in front of every special character; -; ignores any leading "version numbers" thingies that they use in the -; comp.binaries groups, and either replaces anything that looks like -; "2/3" with "[0-9]+/[0-9]+" or, if it can't find something like that, -; replaces the last two numbers with "[0-9]+". This, in my experience, -; should get most postings of a series." -(defun gnus-uu-reginize-string (string) - (let ((count 2) - (vernum "v[0-9]+[a-z][0-9]+:") - reg beg) - (save-excursion - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) - (erase-buffer) - (insert (regexp-quote string)) - (setq beg 1) - - (setq case-fold-search nil) - (goto-char 1) - (if (looking-at vernum) - (progn - (replace-match vernum t t) - (setq beg (length vernum)))) - - (goto-char beg) - (if (re-search-forward "[ \t]*[0-9]+/[0-9]+" nil t) - (replace-match " [0-9]+/[0-9]+") - - (goto-char beg) - (if (re-search-forward "[0-9]+[ \t]*of[ \t]*[0-9]+" nil t) - (replace-match "[0-9]+ of [0-9]+") - - (end-of-line) - (while (and (re-search-backward "[0-9]" nil t) (> count 0)) - (while (and - (looking-at "[0-9]") - (< 1 (goto-char (1- (point)))))) - (re-search-forward "[0-9]+" nil t) - (replace-match "[0-9]+") - (backward-char 5) - (setq count (1- count))))) - - (goto-char beg) - (while (re-search-forward "[ \t]+" nil t) - (replace-match "[ \t]*" t t)) - - (buffer-substring 1 (point-max))))) - -; Finds all articles that matches the regular expression given. -; Returns the resulting list. SUBJECT is the regular expression to be -; matched. If it is nil, the current article name will be used. If -; MARK-ARTICLES is non-nil, articles found are marked. If ONLY-UNREAD -; is non-nil, only unread articles are chose. If DO-NOT-TRANSLATE is -; non-nil, article names are not equialized before sorting. -(defun gnus-uu-get-list-of-articles (&optional subject mark-articles only-unread do-not-translate) - (let (beg end reg-subject list-of-subjects list-of-numbers art-num) - (save-excursion - -; If the subject is not given, this function looks at the current subject -; and takes that. - - (if subject - (setq reg-subject subject) - (end-of-line) - (setq end (point)) - (beginning-of-line) - (if (not (re-search-forward "\\] " end t)) - (progn (message "No valid subject chosen") (sit-for 2)) - (setq subject (buffer-substring (point) end)) - (setq reg-subject - (concat "\\[.*\\] " (gnus-uu-reginize-string subject))))) - -; (message reg-subject)(sleep-for 2) - - (if reg-subject - (progn - -; Collect all subjects matching reg-subject. - - (let ((case-fold-search t)) - (goto-char 1) - (while (re-search-forward reg-subject nil t) - (beginning-of-line) - (setq beg (point)) - (if (or (not only-unread) (looking-at " \\|-")) - (progn - (end-of-line) - (setq list-of-subjects (cons - (buffer-substring beg (point)) - list-of-subjects))) - (end-of-line)))) - -; Expand all numbers in all the subjects: (hi9 -> hi0009, etc). - - (setq list-of-subjects (gnus-uu-expand-numbers - list-of-subjects - (not do-not-translate))) - -; Sort the subjects. - - (setq list-of-subjects (sort list-of-subjects 'gnus-uu-string<)) - -; Get the article numbers from the sorted list of subjects. - - (while list-of-subjects - (setq art-num (gnus-uu-article-number (car list-of-subjects))) - (if mark-articles (gnus-summary-mark-as-read art-num ?#)) - (setq list-of-numbers (cons art-num list-of-numbers)) - (setq list-of-subjects (cdr list-of-subjects))) - - (setq list-of-numbers (nreverse list-of-numbers)))) - - list-of-numbers))) - -; Takes a list of strings and "expands" all numbers in all the -; strings. That is, this function makes all numbers equal length by -; prepending lots of zeroes before each number. This is to ease later -; sorting to find out what sequence the articles are supposed to be -; decoded in. Returns the list of expanded strings. -(defun gnus-uu-expand-numbers (string-list &optional translate) - (let (string out-list pos num) - (save-excursion - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) - (while string-list - (erase-buffer) - (setq string (car string-list)) - (setq string-list (cdr string-list)) - (insert string) - (goto-char 1) - (while (re-search-forward "[ \t]+" nil t) - (replace-match " ")) - (goto-char 1) - (if translate - (while (re-search-forward "[A-Za-z]" nil t) - (replace-match "a" t t))) - - (goto-char 1) - (if (not (search-forward "] " nil t)) - () - (while (re-search-forward "[0-9]+" nil t) - (replace-match - (format "%06d" - (string-to-int (buffer-substring - (match-beginning 0) (match-end 0)))))) - (setq string (buffer-substring 1 (point-max))) - (setq out-list (cons string out-list))))) - out-list)) - -; Used in a sort for finding out what string is bigger, but ignoring -; everything before the subject part. -(defun gnus-uu-string< (string1 string2) - (string< (substring string1 (string-match "\\] " string1)) - (substring string2 (string-match "\\] " string2)))) - - -;; gnus-uu-grab-article -; -; This is the general multi-article treatment function. It takes a -; list of articles to be grabbed and a function to apply to each -; article. It puts the result in `gnus-uu-result-buffer'. -; -; The function to be called should take two parameters. The first -; parameter is the article buffer. The function should leave the -; result, if any, in this buffer. This result is then appended on to -; the `gnus-uu-result-buffer'. Most treatment functions will just -; generate files... -; -; The second parameter is the state of the list of articles, and can -; have four values: `first', `middle', `last' and `first-and-last'. -; -; The function should return a list. The list may contain the -; following symbols: -; `error' if an error occurred -; `begin' if the beginning of an encoded file has been received -; If the list returned contains a `begin', the first element of -; the list *must* be a string with the file name of the decoded -; file. -; `end' if the the end of an encoded file has been received -; `middle' if the article was a body part of an encoded file -; `wrong-type' if the article was not a part of an encoded file -; `ok', which can be used everything is ok - -(defvar gnus-uu-has-been-grabbed nil) - -(defun gnus-uu-unmark-list-of-grabbed (&optional dont-unmark-last-article) - (let (art) - (if (not (and gnus-uu-has-been-grabbed - gnus-uu-unmark-articles-not-decoded)) - () - (if dont-unmark-last-article - (progn - (setq art (car gnus-uu-has-been-grabbed)) - (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed)))) - (while gnus-uu-has-been-grabbed - (gnus-summary-mark-as-unread (car gnus-uu-has-been-grabbed) t) - (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) - (if dont-unmark-last-article - (setq gnus-uu-has-been-grabbed (list art)))))) - - -; This function takes a list of articles and a function to apply to -; each article grabbed. The result of the function is appended on to -; `gnus-uu-result-buffer'. -; -; This function returns a list of files decoded if the grabbing and -; the process-function has been successful and nil otherwise. -(defun gnus-uu-grab-articles (list-of-articles process-function &optional sloppy limit) - (let ((result-buffer (get-buffer-create gnus-uu-result-buffer)) - (state 'first) - (wrong-type t) - has-been-begin has-been-end - article result-file result-files process-state) - - (save-excursion - (set-buffer result-buffer) - (erase-buffer)) - (setq gnus-uu-has-been-grabbed nil) - - (while (and list-of-articles - (not (memq 'error process-state)) - (or sloppy - (not (memq 'end process-state)))) - - (setq article (car list-of-articles)) - (setq list-of-articles (cdr list-of-articles)) - (setq gnus-uu-has-been-grabbed (cons article gnus-uu-has-been-grabbed)) - - (if (> article gnus-uu-highest-article-number) - (setq gnus-uu-highest-article-number article)) - - (if (eq list-of-articles ()) - (if (eq state 'first) - (setq state 'first-and-last) - (setq state 'last))) - - (message "Getting article %d" article) - (if (not (= (or gnus-current-article 0) article)) - (gnus-summary-display-article article)) - (gnus-summary-mark-as-read article) - - (save-excursion (set-buffer gnus-article-buffer) (widen)) - - (setq process-state (funcall process-function gnus-article-buffer state)) - -; (message "process-state er %s" process-state)(sleep-for 3) - - (if (or (memq 'begin process-state) - (and (or (eq state 'first) (eq state 'first-and-last)) - (memq 'ok process-state))) - (progn - (if has-been-begin - (if (file-exists-p result-file) (delete-file result-file))) - (setq result-file (car process-state)) - (setq has-been-begin t) - (setq has-been-end nil))) - - (if (memq 'end process-state) - (progn - (setq gnus-uu-has-been-grabbed nil) - (setq result-files (cons result-file result-files)) - (setq has-been-end t) - (setq has-been-begin nil) - (if (and limit (= (length result-files) limit)) - (progn - (setq list-of-articles nil) - (setq gnus-uu-marked-article-list nil))))) - - (if (and (or (eq state 'last) (eq state 'first-and-last)) - (not (memq 'end process-state))) - (if (and result-file (file-exists-p result-file)) - (delete-file result-file))) - - (setq result-file nil) - - (if (not (memq 'wrong-type process-state)) - (setq wrong-type nil) - (if gnus-uu-unmark-articles-not-decoded - (gnus-summary-mark-as-unread article t))) - - (if sloppy (setq wrong-type nil)) - - (if (and (not has-been-begin) - (not sloppy) - (or (memq 'end process-state) - (memq 'middle process-state))) - (progn - (setq process-state (list 'error)) - (message "No begin part at the beginning") - (sleep-for 2)) - (setq state 'middle))) - - (if result-files - () - (if (not has-been-begin) - (message "Wrong type file") - (if (memq 'error process-state) - (setq result-files nil) - (if (not (or (memq 'ok process-state) - (memq 'end process-state))) - (progn - (message "End of articles reached before end of file") - (setq result-files nil)) - (gnus-uu-unmark-list-of-grabbed))))) - (setq gnus-uu-list-of-files-decoded result-files) - result-files)) - -(defun gnus-uu-uudecode-sentinel (process event) - (delete-process (get-process process))) - -; Uudecodes a file asynchronously. -(defun gnus-uu-uustrip-article-as (process-buffer in-state) - (let ((state (list 'ok)) - (process-connection-type nil) - start-char pst name-beg name-end) - (save-excursion - (set-buffer process-buffer) - (let ((case-fold-search nil) - (buffer-read-only nil)) - - (goto-char 1) - - (if gnus-uu-kill-carriage-return - (progn - (while (search-forward "\r" nil t) - (delete-backward-char 1)) - (goto-char 1))) - - (if (not (re-search-forward gnus-uu-begin-string nil t)) - (if (not (re-search-forward gnus-uu-body-line nil t)) - (setq state (list 'wrong-type)))) - - (if (memq 'wrong-type state) - () - (beginning-of-line) - (setq start-char (point)) - - (if (looking-at gnus-uu-begin-string) - (progn - (setq name-end (match-end 1)) - - ; Replace any slashes and spaces in file names before decoding - (goto-char (setq name-beg (match-beginning 1))) - (while (re-search-forward "/" name-end t) - (replace-match ",")) - (goto-char name-beg) - (while (re-search-forward " " name-end t) - (replace-match "_")) - - (setq gnus-uu-file-name (buffer-substring name-beg name-end)) - (and gnus-uu-uudecode-process - (setq pst (process-status - (or gnus-uu-uudecode-process "nevair"))) - (if (or (eq pst 'stop) (eq pst 'run)) - (progn - (delete-process gnus-uu-uudecode-process) - (gnus-uu-unmark-list-of-grabbed t)))) - (setq gnus-uu-uudecode-process - (start-process - "*uudecode*" - (get-buffer-create gnus-uu-output-buffer-name) - "sh" "-c" - (format "cd %s ; uudecode" gnus-uu-work-dir))) - (set-process-sentinel - gnus-uu-uudecode-process 'gnus-uu-uudecode-sentinel) - (setq state (list 'begin)) - (gnus-uu-add-file (concat gnus-uu-work-dir gnus-uu-file-name))) - (setq state (list 'middle))) - - (goto-char (point-max)) - - (re-search-backward - (concat gnus-uu-body-line "\\|" gnus-uu-end-string) nil t) - (beginning-of-line) - - (if (looking-at gnus-uu-end-string) - (setq state (cons 'end state))) - (forward-line 1) - - (and gnus-uu-uudecode-process - (setq pst (process-status - (or gnus-uu-uudecode-process "nevair"))) - (if (or (eq pst 'run) (eq pst 'stop)) - (progn - (if gnus-uu-correct-stripped-uucode - (progn - (gnus-uu-check-correct-stripped-uucode - start-char (point)) - (goto-char (point-max)) - (re-search-backward - (concat gnus-uu-body-line "\\|" - gnus-uu-end-string) - nil t) - (forward-line 1))) - (condition-case err - (process-send-region gnus-uu-uudecode-process - start-char (point)) - (error - (progn - (message "gnus-uu: Couldn't uudecode") - (sleep-for 2) - (setq state (list 'wrong-type)) - (delete-process gnus-uu-uudecode-process)))) - (if (memq 'end state) - (accept-process-output gnus-uu-uudecode-process))) - (setq state (list 'wrong-type)))) - (if (not gnus-uu-uudecode-process) - (setq state (list 'wrong-type))))) - - (if (memq 'begin state) - (cons (concat gnus-uu-work-dir gnus-uu-file-name) state) - state)))) - -; This function is used by `gnus-uu-grab-articles' to treat -; a shared article. -(defun gnus-uu-unshar-article (process-buffer in-state) - (let ((state (list 'ok)) - start-char) - (save-excursion - (set-buffer process-buffer) - (goto-char 1) - (if (not (re-search-forward gnus-uu-shar-begin-string nil t)) - (setq state (list 'wrong-type)) - (beginning-of-line) - (setq start-char (point)) - (call-process-region - start-char (point-max) "sh" nil - (get-buffer-create gnus-uu-output-buffer-name) nil - "-c" (concat "cd " gnus-uu-shar-directory " ; sh")))) - state)) - -; Returns the name of what the shar file is going to unpack. -(defun gnus-uu-find-name-in-shar () - (let ((oldpoint (point)) - res) - (goto-char 1) - (if (re-search-forward gnus-uu-shar-name-marker nil t) - (setq res (buffer-substring (match-beginning 1) (match-end 1)))) - (goto-char oldpoint) - res)) - -; Returns the article number of the given subject. -(defun gnus-uu-article-number (subject) - (let (end) - (string-match "[0-9]+[^0-9]" subject 1) - (setq end (match-end 0)) - (string-to-int - (substring subject (string-match "[0-9]" subject 1) end)))) - -; `gnus-uu-choose-action' chooses what action to perform given the name -; and `gnus-uu-file-action-list'. Returns either nil if no action is -; found, or the name of the command to run if such a rule is found. -(defun gnus-uu-choose-action (file-name file-action-list &optional no-ignore) - (let ((action-list (copy-sequence file-action-list)) - rule action) - (and - (or no-ignore - (and (not - (and gnus-uu-ignore-files-by-name - (string-match gnus-uu-ignore-files-by-name file-name))) - (not - (and gnus-uu-ignore-files-by-type - (string-match gnus-uu-ignore-files-by-type - (or (gnus-uu-choose-action - file-name gnus-uu-ext-to-mime-list t) - "")))))) - (while (not (or (eq action-list ()) action)) - (setq rule (car action-list)) - (setq action-list (cdr action-list)) - (if (string-match (car rule) file-name) - (setq action (car (cdr rule)))))) - action)) - -(defun gnus-uu-save-directory (from-dir &optional default-dir ignore-existing) - (let (dir file-name command files file) - (setq files (directory-files from-dir t)) - (if default-dir - (setq dir default-dir) - (setq dir (gnus-uu-read-directory - (concat "Where do you want the file" - (if (< 3 (length files)) "s" "") "? ")))) - - (while files - (setq file (car files)) - (setq files (cdr files)) - (string-match "/[^/]*$" file) - (setq file-name (substring file (1+ (match-beginning 0)))) - (if (string-match "^\\.\\.?$" file-name) - () - (if (and (not ignore-existing) (file-exists-p (concat dir file-name))) - (setq file-name - (read-file-name "File exists. Enter a new name: " dir - (concat dir file-name) nil file-name)) - (setq file-name (concat dir file-name))) - (rename-file file file-name t))))) - -; Moves the file from the tmp directory to where the user wants it. -(defun gnus-uu-save-file (from-file-name &optional default-dir ignore-existing) - (let (dir file-name command) - (string-match "/[^/]*$" from-file-name) - (setq file-name (substring from-file-name (1+ (match-beginning 0)))) - (if default-dir - (setq dir default-dir) - (setq dir (gnus-uu-read-directory "Where do you want the file? "))) - (if (and (not ignore-existing) (file-exists-p (concat dir file-name))) - (setq file-name - (read-file-name "File exist. Enter a new name: " dir - (concat dir file-name) nil file-name)) - (setq file-name (concat dir file-name))) - (rename-file from-file-name file-name t))) - -(defun gnus-uu-read-directory (prompt &optional default) - (let (dir ok create) - (while (not ok) - (setq ok t) - (setq dir (if default default - (read-file-name prompt gnus-uu-current-save-dir - gnus-uu-current-save-dir))) - (while (string-match "/$" dir) - (setq dir (substring dir 0 (match-beginning 0)))) - (if (file-exists-p dir) - (if (not (file-directory-p dir)) - (progn - (setq ok nil) - (message "%s is a file" dir) - (sit-for 2))) - (setq create ?o) - (while (not (or (= create ?y) (= create ?n))) - (message "%s: No such directory. Do you want to create it? (y/n)" - dir) - (setq create (read-char))) - (if (= create ?y) (make-directory dir)))) - (setq gnus-uu-current-save-dir (concat dir "/")))) - -; Unpacks an archive and views all the files in it. Returns t if -; viewing one or more files is successful. -(defun gnus-uu-treat-archive (file-path) - (let ((did-unpack t) - action command files file file-name dir) - (setq action (gnus-uu-choose-action - file-path (append gnus-uu-user-archive-rules - (if gnus-uu-ignore-default-archive-rules - nil - gnus-uu-default-archive-rules)))) - - (if (not action) (error "No unpackers for the file %s" file-path)) - - (string-match "/[^/]*$" file-path) - (setq file-name (substring file-path (1+ (match-beginning 0)))) - (setq dir (substring file-path 0 (match-beginning 0))) - - (if (gnus-uu-string-in-list action gnus-uu-destructive-archivers) - (copy-file file-path (concat file-path "~") t)) - - (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) - - (save-excursion - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) - (erase-buffer)) - - (message "Unpacking: %s..." (gnus-uu-command action file-path)) - - (if (= 0 (call-process "sh" nil - (get-buffer-create gnus-uu-output-buffer-name) - nil "-c" command)) - (message "") - (if (not gnus-uu-use-interactive-view) - (progn - (message "Error during unpacking of archive") - (sleep-for 2))) - (setq did-unpack nil)) - - (if (gnus-uu-string-in-list action gnus-uu-destructive-archivers) - (rename-file (concat file-path "~") file-path t)) - - did-unpack)) - -; Tries to view all the files in the given directory. Returns t if -; viewing one or more files is successful. -(defun gnus-uu-view-directory (dir &optional dont-delete-files not-top) - (let ((first t) - files file did-view ignore-files) - (setq files (directory-files dir t "[^/][^\\.][^\\.]?$")) - (gnus-uu-add-file files) - (setq ignore-files files) - - (while (gnus-uu-unpack-archives - files (if not-top (list ".") - (if first () ignore-files))) - (setq first nil) - (gnus-uu-add-file - (setq files (directory-files dir t "[^/][^\\.][^\\.]?$")))) - - (gnus-uu-add-file (directory-files dir t "[^/][^\\.][^\\.]?$")) - - (while files - (setq file (car files)) - (setq files (cdr files)) - (if (not (string= (or (gnus-uu-get-action file) "") "gnus-uu-archive")) - (progn - (set-file-modes file 448) - (if (file-directory-p file) - (setq did-view (or (gnus-uu-view-directory file - dont-delete-files - t) - did-view)) - (setq did-view (or (gnus-uu-view-file file t) did-view))))) - (if (and (not dont-delete-files) (not gnus-uu-asynchronous) - (file-exists-p file)) - (delete-file file))) - - (if (and (not gnus-uu-asynchronous) (not dont-delete-files)) - (if (string-match "/$" dir) - (delete-directory (substring dir 0 (match-beginning 0))) - (delete-directory dir))) - did-view)) - -(defun gnus-uu-unpack-archives (files &optional ignore) - (let (path did-unpack) - (while files - (setq path (car files)) - (setq files (cdr files)) - (if (not (gnus-uu-string-in-list path ignore)) - (if (string= (or (gnus-uu-get-action - (gnus-uu-name-from-path path)) "") - "gnus-uu-archive") - (progn - (if (and (not (setq did-unpack (gnus-uu-treat-archive path))) - gnus-uu-use-interactive-view) - (gnus-uu-enter-interactive-file - "# error during unpacking of" path)) - (if ignore (delete-file path)))))) - did-unpack)) - - -;; Manual marking - -(defun gnus-uu-enter-mark-in-list () - (let (article beg) - (save-excursion - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq article (gnus-uu-article-number - (buffer-substring beg (point)))) - (message "Adding article %d to list" article) - (setq gnus-uu-marked-article-list - (cons article gnus-uu-marked-article-list))))) - -(defun gnus-uu-mark-article (&optional dont-move) - "Marks the current article to be decoded later." - (interactive) - (gnus-uu-enter-mark-in-list) - (gnus-summary-mark-as-read nil ?#) - (gnus-summary-next-subject 1 nil)) - -(defun gnus-uu-unmark-article () - "Unmarks the current article." - (interactive) - (let ((in (copy-sequence gnus-uu-marked-article-list)) - out article beg found - (old-point (point))) - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq article (gnus-uu-article-number (buffer-substring beg (point)))) - (message "Removing article %d" article) - (while in - (if (not (= (car in) article)) - (setq out (cons (car in) out)) - (setq found t) - (message "Removing article %d" article)) - (setq in (cdr in))) - (if (not found) (message "Not a marked article.")) - (setq gnus-uu-marked-article-list (reverse out)) - (gnus-summary-mark-as-unread nil t) - (gnus-summary-next-subject 1 nil))) - -(defun gnus-uu-unmark-all-articles () - "Removes the mark from all articles marked for decoding." - (interactive) - (while gnus-uu-marked-article-list - (gnus-summary-goto-subject (car gnus-uu-marked-article-list)) - (gnus-summary-mark-as-unread nil t) - (setq gnus-uu-marked-article-list (cdr gnus-uu-marked-article-list)))) - -(defun gnus-uu-mark-by-regexp () - "Asks for a regular expression and marks all articles that match." - (interactive) - (let (exp) - (setq exp (read-from-minibuffer "Mark (regexp): ")) - (setq gnus-uu-marked-article-list - (append gnus-uu-marked-article-list - (reverse (gnus-uu-get-list-of-articles exp t)))) - (message ""))) - -(defun gnus-uu-mark-thread () - "Marks all articles downwards in this thread." - (interactive) - (beginning-of-line) - (let (level) - (if (not (search-forward ":" nil t)) - () - (setq level (current-column)) - (gnus-uu-enter-mark-in-list) - (gnus-summary-mark-as-read nil ?#) - (gnus-summary-search-forward) - (while (< level (current-column)) - (gnus-uu-enter-mark-in-list) - (gnus-summary-mark-as-read nil ?#) - (gnus-summary-search-forward)) - (gnus-summary-search-backward)))) - - -;; Various stuff - -(defun gnus-uu-string-in-list (string list) - (while (and list - (not (string= (car list) string)) - (setq list (cdr list)))) - list) - -(defun gnus-uu-name-from-path (path) - (string-match "/[^/]*$" path) - (substring path (1+ (match-beginning 0)))) - -(defun gnus-uu-directory-files (dir) - (let (files out file) - (setq files (directory-files dir t)) - (while files - (setq file (car files)) - (setq files (cdr files)) - (if (not (string-match "/\\.\\.?$" file)) - (setq out (cons file out)))) - (setq out (reverse out)) - out)) - -(defun gnus-uu-check-correct-stripped-uucode (start end) - (let (found beg length short) - (if (not gnus-uu-correct-stripped-uucode) - () - (goto-char start) - - (if (re-search-forward " \\|`" end t) - (progn - (goto-char start) - (while (not (eobp)) - (progn - (if (looking-at "\n") (replace-match "")) - (forward-line 1)))) - - (while (not (eobp)) - (if (looking-at (concat gnus-uu-begin-string "\\|" - gnus-uu-end-string)) - () - (if (not found) - (progn - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq length (- (point) beg)))) - (setq found t) - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (if (not (= length (- (point) beg))) - (insert (make-string (- length (- (point) beg)) ? )))) - (forward-line 1)))))) - -(defun gnus-uu-initialize () - (setq gnus-uu-highest-article-number 1) - (gnus-uu-check-for-generated-files) - (setq gnus-uu-tmp-dir (expand-file-name gnus-uu-tmp-dir)) - (if (string-match "[^/]$" gnus-uu-tmp-dir) - (setq gnus-uu-tmp-dir (concat gnus-uu-tmp-dir "/"))) - (if (not (file-directory-p gnus-uu-tmp-dir)) - (error "Temp directory %s doesn't exist" gnus-uu-tmp-dir) - (if (not (file-writable-p gnus-uu-tmp-dir)) - (error "Temp directory %s can't be written to" gnus-uu-tmp-dir))) - (setq gnus-uu-work-dir - (concat gnus-uu-tmp-dir (make-temp-name "gnus"))) - (gnus-uu-add-file gnus-uu-work-dir) - (if (not (file-directory-p gnus-uu-work-dir)) - (make-directory gnus-uu-work-dir)) - (setq gnus-uu-work-dir (concat gnus-uu-work-dir "/")) - (setq gnus-uu-interactive-file-list nil)) - -; Kills the temporary uu buffers, kills any processes, etc. -(defun gnus-uu-clean-up () - (let (buf pst) - (and gnus-uu-uudecode-process - (setq pst (process-status (or gnus-uu-uudecode-process "nevair"))) - (if (or (eq pst 'stop) (eq pst 'run)) - (delete-process gnus-uu-uudecode-process))) - (and (not gnus-uu-asynchronous) - (setq buf (get-buffer gnus-uu-output-buffer-name)) - (kill-buffer buf)) - (and (setq buf (get-buffer gnus-uu-result-buffer)) - (kill-buffer buf)))) - -; `gnus-uu-check-for-generated-files' deletes any generated files that -; hasn't been deleted, if, for instance, the user terminated decoding -; with `C-g'. -(defun gnus-uu-check-for-generated-files () - (let (file dirs) - (while gnus-uu-generated-file-list - (setq file (car gnus-uu-generated-file-list)) - (setq gnus-uu-generated-file-list (cdr gnus-uu-generated-file-list)) - (if (not (string-match "/\\.[\\.]?$" file)) - (progn - (if (file-directory-p file) - (setq dirs (cons file dirs)) - (if (file-exists-p file) - (delete-file file)))))) - (setq dirs (nreverse dirs)) - (while dirs - (setq file (car dirs)) - (setq dirs (cdr dirs)) - (if (file-directory-p file) - (if (string-match "/$" file) - (delete-directory (substring file 0 (match-beginning 0))) - (delete-directory file)))))) - -; Add a file (or a list of files) to be checked (and deleted if it/they -; still exists upon exiting the newsgroup). -(defun gnus-uu-add-file (file) - (if (stringp file) - (setq gnus-uu-generated-file-list - (cons file gnus-uu-generated-file-list)) - (setq gnus-uu-generated-file-list - (append file gnus-uu-generated-file-list)))) - -; Go to the next unread subject. If there is no further unread -; subjects, go to the last subject in the buffer. -(defun gnus-uu-summary-next-subject () - (let (opi) - (if (not (gnus-summary-search-forward t)) - (progn - (goto-char 1) - (sit-for 0) - (gnus-summary-goto-subject gnus-uu-highest-article-number))) - - ; You may well find all this a bit puzzling - so do I, but I seem - ; to have to do something like this to move to the next unread article, - ; as `sit-for' seems to do some rather strange things here. Might - ; be a bug in my head, probably. - (setq opi (point)) - (sit-for 0) - (goto-char opi) - (gnus-summary-recenter))) - -; Inputs an action and a file and returns a full command, putting -; ticks round the file name and escaping any ticks in the file name. -(defun gnus-uu-command (action file) - (let ((ofile "")) - (while (string-match "`\\|\"\\|\\$\\|\\\\" file) - (progn - (setq ofile - (concat ofile (substring file 0 (match-beginning 0)) "\\" - (substring file (match-beginning 0) (match-end 0)))) - (setq file (substring file (1+ (match-beginning 0)))))) - (setq ofile (concat "\"" ofile file "\"")) - (if (string-match "%s" action) - (format action ofile) - (concat action " " ofile)))) - - -;; Initializing -(add-hook 'gnus-exit-group-hook - '(lambda () - (gnus-uu-clean-up) - (setq gnus-uu-marked-article-list nil) - (gnus-uu-check-for-generated-files))) - - -;; Interactive exec mode - -(defvar gnus-uu-output-window nil) -(defvar gnus-uu-mode-hook nil) - -(defvar gnus-uu-mode-map nil) -(if gnus-uu-mode-map - () - (setq gnus-uu-mode-map (make-sparse-keymap)) - (define-key gnus-uu-mode-map "\C-c\C-x" 'gnus-uu-interactive-execute) - (define-key gnus-uu-mode-map "\C-c\C-v" 'gnus-uu-interactive-execute) - (define-key gnus-uu-mode-map "\C-m" 'gnus-uu-interactive-execute) - (define-key gnus-uu-mode-map "\C-c\C-c" 'gnus-uu-interactive-end) - (define-key gnus-uu-mode-map "\C-c\C-z" - 'gnus-uu-interactive-save-current-file) - (define-key gnus-uu-mode-map "\C-c\C-s" - 'gnus-uu-interactive-save-current-file-silent) - (define-key gnus-uu-mode-map "\C-c\C-w" 'gnus-uu-interactive-save-all-files) - (define-key gnus-uu-mode-map "\C-c\C-o" 'gnus-uu-interactive-save-original-file) - (define-key gnus-uu-mode-map "\C-c\C-r" 'gnus-uu-interactive-rescan-directory) - (define-key gnus-uu-mode-map "\C-c\C-d" 'gnus-uu-interactive-scan-directory) - ) - -(defun gnus-uu-interactive-set-up-windows () - (let (int-buf out-buf) - (set-buffer - (setq int-buf (get-buffer-create gnus-uu-interactive-buffer-name))) - (if (not (get-buffer-window int-buf)) - (switch-to-buffer-other-window int-buf)) - (pop-to-buffer int-buf) - (setq out-buf (get-buffer-create gnus-uu-output-buffer-name)) - (if (not (get-buffer-window out-buf)) - (progn - (setq gnus-uu-output-window - (split-window nil (- (window-height) - gnus-uu-output-window-height))) - (set-window-buffer gnus-uu-output-window out-buf))))) - -(defun gnus-uu-do-interactive (&optional dont-do-windows) - (if (not gnus-uu-interactive-file-list) - (gnus-uu-enter-interactive-file "#" "")) - (if (not dont-do-windows) (gnus-uu-interactive-set-up-windows)) - (save-excursion - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) - (erase-buffer)) - (set-buffer (get-buffer-create gnus-uu-interactive-buffer-name)) - (goto-char 1) - (forward-line 3) - (run-hooks 'gnus-uu-mode-hook)) - -(defun gnus-uu-enter-interactive-file (action file) - (let (command) - (save-excursion - (set-buffer (get-buffer-create gnus-uu-interactive-buffer-name)) - (if (not gnus-uu-interactive-file-list) - (progn - (erase-buffer) - (gnus-uu-mode) - (insert - "# Press return to execute a command. -# Press `C-c C-c' to exit interactive view. - -"))) - (setq gnus-uu-interactive-file-list - (cons file gnus-uu-interactive-file-list)) -; (if (string-match (concat "^" gnus-uu-work-dir) file) -; (setq file (substring file (match-end 0)))) - (setq command (gnus-uu-command action file)) - (goto-char (point-max)) - (insert (format "%s\n" command))))) - -(defun gnus-uu-interactive-execute () - "Executes the command on the current line in interactive mode." - (interactive) - (let (beg out-buf command) - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq command (buffer-substring beg (point))) - (setq out-buf (get-buffer-create gnus-uu-output-buffer-name)) - (save-excursion - (set-buffer out-buf) - (erase-buffer) - (insert (format "$ %s \n\n" command))) - (setq command (format "cd %s ; %s" gnus-uu-work-dir command)) - (message "Executing...") - (if gnus-uu-asynchronous - (start-process "gnus-uu-view" out-buf "sh" "-c" command) - (call-process "sh" nil out-buf nil "-c" command) - (message "")) - (end-of-line) - (if (= (forward-line 1) 1) - (progn - (end-of-line) - (insert "\n"))) - (beginning-of-line))) - -(defun gnus-uu-interactive-end () - "This function exits interactive view mode and returns to summary mode." - (interactive) - (let (buf) - (delete-window gnus-uu-output-window) - (gnus-uu-clean-up) - (if (not gnus-uu-asynchronous) (gnus-uu-check-for-generated-files)) - (setq buf (get-buffer gnus-uu-interactive-buffer-name)) - (if gnus-article-buffer (switch-to-buffer gnus-article-buffer)) - (if buf (kill-buffer buf)) - (pop-to-buffer gnus-summary-buffer))) - - -(defun gnus-uu-interactive-scan-directory (dir) - "Read any directory and view the files. -When used in interactive mode, the files and commands will be displayed, -as usual, in the interactive mode buffer." - (interactive "DDirectory: ") - (setq gnus-uu-interactive-file-list nil) - (gnus-uu-view-directory dir gnus-uu-use-interactive-view) - (gnus-uu-do-interactive t)) - -(defun gnus-uu-interactive-rescan-directory () - "Reread the directory and view the files. -When used in interactive mode, the files and commands will be displayed, -as usual, in the interactive mode buffer." - (interactive) - (gnus-uu-interactive-scan-directory gnus-uu-work-dir)) - -(defun gnus-uu-interactive-save-original-file () - "Saves the file from whence the file on the current line came from." - (interactive) - (let ((files gnus-uu-list-of-files-decoded) - (filestr "") - file did dir) - (while files - (setq file (car files)) - (setq files (cdr files)) - (if (file-exists-p file) - (progn - (if (not did) - (progn - (setq dir (gnus-uu-read-directory - (format "Where do you want the file%s? " - (if (> (length files) 1) "s" "")))) - (setq did t))) - (setq filestr (concat filestr (gnus-uu-name-from-path file) " ")) - (gnus-uu-save-file file dir t))) - (if did - (message "Saved %s" filestr) - (message "Already saved."))))) - -(defun gnus-uu-interactive-save-current-file-silent () - "Saves the file referred to on the current line in the current directory." - (interactive) - (gnus-uu-interactive-save-current-file t)) - -(defun gnus-uu-interactive-save-current-file (&optional dont-ask silent) - "Saves the file referred to on the current line." - (interactive) - (let (files beg line file) - (setq files (copy-sequence gnus-uu-interactive-file-list)) - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq line (buffer-substring beg (point))) - (while (and files - (not (string-match - (concat "" (regexp-quote (setq file (car files))) "") - line))) - (setq files (cdr files))) - (beginning-of-line) - (forward-line 1) - (if (not files) - (if (not silent) - (progn (message "Could not find file") (sit-for 2))) - (gnus-uu-save-file file (if dont-ask gnus-uu-current-save-dir nil) silent) - (delete-region beg (point))))) - -(defun gnus-uu-interactive-save-all-files () - "Saves all files referred to in the interactive buffer." - (interactive) - (let (dir) - (goto-char 1) - (setq dir (gnus-uu-read-directory "Where do you want the files? ")) - (while (not (eobp)) - (gnus-uu-interactive-save-current-file t t)))) - -(defun gnus-uu-mode () - "Major mode for editing view commands in gnus-uu. - -Commands: -\\<gnus-uu-mode-map>Return, C-c C-v, C-c C-x Execute the current command -\\[gnus-uu-interactive-end]\tEnd interactive mode -\\[gnus-uu-interactive-save-current-file]\tSave the current file -\\[gnus-uu-interactive-save-current-file-silent]\tSave the current file without asking -\twhere to put it -\\[gnus-uu-interactive-save-all-files]\tSave all files -\\[gnus-uu-interactive-save-original-file]\tSave the original file: If the files -\toriginated in an archive, the archive -\tfile is saved. -\\[gnus-uu-interactive-rescan-directory]\tRescan the directory -\\[gnus-uu-interactive-scan-directory]\tScan any directory -" - (interactive) - (kill-all-local-variables) - (use-local-map gnus-uu-mode-map) - (setq mode-name "gnus-uu") - (setq major-mode 'gnus-uu-mode) -) - - (define-key gnus-uu-mode-map "\C-c\C-x" 'gnus-uu-interactive-execute) - (define-key gnus-uu-mode-map "\C-c\C-v" 'gnus-uu-interactive-execute) - (define-key gnus-uu-mode-map "\C-m" 'gnus-uu-interactive-execute) - (define-key gnus-uu-mode-map "\C-c\C-c" 'gnus-uu-interactive-end) - (define-key gnus-uu-mode-map "\C-cs" - 'gnus-uu-interactive-save-current-file) - (define-key gnus-uu-mode-map "\C-c\C-s" - 'gnus-uu-interactive-save-current-file-silent) - (define-key gnus-uu-mode-map "\C-c\C-a" 'gnus-uu-interactive-save-all-files) - (define-key gnus-uu-mode-map "\C-c\C-o" 'gnus-uu-interactive-save-original-file) - - -;; Major mode for posting encoded articles. - -(require 'sendmail) -(require 'rnews) - -; Any function that is to be used as and encoding method will take two -; parameters: PATH-NAME and FILE-NAME. (E.g. "/home/gaga/spiral.jpg" -; and "spiral.jpg", respectively.) The function should return nil if -; the encoding wasn't successful. -(defvar gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode - "Function used for encoding binary files. -There are three functions supplied with gnus-uu for encoding files: -`gnus-uu-post-encode-uuencode', which does straight uuencoding; -`gnus-uu-post-encode-mime', which encodes with base64 and adds MIME -headers; and `gnus-uu-post-encode-mime-uuencode', which encodes with -uuencode and adds MIME headers.") - -(defvar gnus-uu-post-include-before-composing nil - "Non-nil means that gnus-uu will ask for a file to encode before you compose the article. -If this variable is t, you can either include an encoded file with -\\<gnus-uu-post-reply-mode-map>\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article.") - -(defvar gnus-uu-post-length 990 - "Maximum length of an article. -The encoded file will be split into how many articles it takes to -post the entire file.") - -(defvar gnus-uu-post-threaded nil - "Non-nil means that gnus-uu will post the encoded file in a thread. -This may not be smart, as no other decoder I have seen are able to -follow threads when collecting uuencoded articles. (Well, I have seen -one package that does that - gnus-uu, but somehow, I don't think that -counts...) Default is nil.") - -(defvar gnus-uu-post-separate-description t - "Non-nil means that the description will be posted in a separate article. -The first article will typically be numbered (0/x). If this variable -is nil, the description the user enters will be included at the -beginning of the first article, which will be numbered (1/x). Default -is t.") - -(defconst gnus-uu-post-binary-separator "--binary follows this line--") -(defvar gnus-uu-post-message-id nil) -(defvar gnus-uu-post-inserted-file-name nil) -(defvar gnus-uu-winconf-post-news nil) - -; The following map and mode was taken from rnewspost.el and edited -; somewhat. -(defvar gnus-uu-post-reply-mode-map () "Mode map used by gnus-uu-post-reply.") -(or gnus-uu-post-reply-mode-map - (progn - (setq gnus-uu-post-reply-mode-map (make-keymap)) - (define-key gnus-uu-post-reply-mode-map "\C-c?" 'describe-mode) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-f\C-d" - 'news-reply-distribution) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-f\C-k" - 'news-reply-keywords) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-f\C-n" - 'news-reply-newsgroups) - - (define-key gnus-uu-post-reply-mode-map "\C-c\C-f\C-f" - 'news-reply-followup-to) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-f\C-s" 'mail-subject) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-f\C-a" - 'gnus-uu-post-reply-summary) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-r" - 'news-caesar-buffer-body) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-w" 'news-reply-signature) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-y" - 'news-reply-yank-original) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-q" - 'mail-fill-yanked-message) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-c" - 'gnus-uu-post-news-inews) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-s" - 'gnus-uu-post-news-inews) - (define-key gnus-uu-post-reply-mode-map "\C-c\C-i" - 'gnus-uu-post-insert-binary-in-article) - )) - -; This mode was taken from rnewspost.el and modified slightly. -(defun gnus-uu-post-reply-mode () - "Major mode for editing binary news to be posted on USENET. -First-time posters are asked to please read the articles in newsgroup: - news.announce.newusers . - -Like news-reply-mode, which is like Text Mode, but with these -additional commands: - -\\<gnus-uu-post-reply-mode-map>\\[gnus-uu-post-news-inews] post the message. -C-c C-f move to a header field (and create it if there isn't): - C-c C-f C-n move to Newsgroups: C-c C-f C-s move to Subj: - C-c C-f C-f move to Followup-To: C-c C-f C-k move to Keywords: - C-c C-f C-d move to Distribution: C-c C-f C-a move to Summary: -C-c C-y news-reply-yank-original (insert current message, in NEWS). -C-c C-q mail-fill-yanked-message (fill what was yanked). -C-c C-r caesar rotate all letters by 13 places in the article's body (rot13). -\\[gnus-uu-post-insert-binary-in-article] encode and include a file in this article. - -This mode is almost identical to news-reply-mode, but has some -additional commands for treating encoded binary articles. In -particular, \\[gnus-uu-post-news-inews] will ask for a file to include, if -one hasn't been included already. It will post, first, the message -composed, and then it will post as many additional articles it takes -to post the entire encoded files. - - Relevant Variables - - `gnus-uu-post-encode-method' - There are three functions supplied with gnus-uu for encoding files: - `gnus-uu-post-encode-uuencode', which does straight uuencoding; - `gnus-uu-post-encode-mime', which encodes with base64 and adds MIME - headers; and `gnus-uu-post-encode-mime-uuencode', which encodes with - uuencode and adds MIME headers. - - `gnus-uu-post-include-before-composing' - Non-nil means that gnus-uu will ask for a file to encode before you - compose the article. If this variable is t, you can either include - an encoded file with `C-c C-i' or have one included for you when you - post the article. - - `gnus-uu-post-length' - Maximum length of an article. The encoded file will be split into how - many articles it takes to post the entire file. - - `gnus-uu-post-separate-description' - Non-nil means that the description will be posted in a separate - article. The first article will typically be numbered (0/x). If - this variable is nil, the description the user enters will be - included at the beginning of the first article, which will be - numbered (1/x). Default is t. - - `gnus-uu-post-threaded' - Non-nil means that gnus-uu will post the encoded file in a thread. - This may not be smart, as no other decoder I have seen are able to - follow threads when collecting uuencoded articles. (Well, I have seen - one package that does that - gnus-uu, but somehow, I don't think that - counts...) Default is nil. -" - (interactive) - ;; require... - (or (fboundp 'mail-setup) (load "sendmail")) - (kill-all-local-variables) - (make-local-variable 'mail-reply-buffer) - (setq mail-reply-buffer nil) - (set-syntax-table text-mode-syntax-table) - (use-local-map gnus-uu-post-reply-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) - (setq major-mode 'gnus-uu-post-reply-mode) - (setq mode-name "Gnus UU News") - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat mail-header-separator "$\\|" - paragraph-start)) - (setq paragraph-separate (concat mail-header-separator "$\\|" - paragraph-separate)) - (run-hooks 'text-mode-hook 'gnus-uu-post-reply-mode-hook)) - -(defun gnus-uu-post-news () - "Compose an article and post an encoded file." - (interactive) - (setq gnus-uu-post-inserted-file-name nil) - (setq gnus-uu-winconf-post-news (current-window-configuration)) - (let (news-reply-mode) - (fset 'news-reply-mode 'gnus-uu-post-reply-mode) - (gnus-summary-post-news) - (if gnus-uu-post-include-before-composing - (save-excursion (setq gnus-uu-post-inserted-file-name - (gnus-uu-post-insert-binary)))))) - -(defun gnus-uu-post-insert-binary-in-article () - "Inserts an encoded file in the buffer. -The user will be asked for a file name." - (interactive) - (if (not (eq (current-buffer) (get-buffer gnus-post-news-buffer))) - (error "Not in post-news buffer")) - (save-excursion - (setq gnus-uu-post-inserted-file-name (gnus-uu-post-insert-binary)))) - -; Encodes with uuencode and substitutes all spaces with backticks. -(defun gnus-uu-post-encode-uuencode (path file-name) - (if (gnus-uu-post-encode-file "uuencode" path file-name) - (progn - (goto-char 1) - (forward-line 1) - (while (re-search-forward " " nil t) - (replace-match "`")) - t))) - -; Encodes with uuencode and adds MIME headers. -(defun gnus-uu-post-encode-mime-uuencode (path file-name) - (if (gnus-uu-post-encode-uuencode path file-name) - (progn - (gnus-uu-post-make-mime file-name "x-uue") - t))) - -; Encodes with base64 and adds MIME headers -(defun gnus-uu-post-encode-mime (path file-name) - (if (gnus-uu-post-encode-file "mmencode" path file-name) - (progn - (gnus-uu-post-make-mime file-name "base64") - t))) - -; Adds MIME headers. -(defun gnus-uu-post-make-mime (file-name encoding) - (goto-char 1) - (insert (format "Content-Type: %s; name=\"%s\"\n" - (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list) - file-name)) - (insert (format "Content-Transfer-Encoding: %s\n\n" encoding)) - (save-restriction - (set-buffer gnus-post-news-buffer) - (goto-char 1) - (re-search-forward mail-header-separator) - (beginning-of-line) - (forward-line -1) - (narrow-to-region 1 (point)) - (or (mail-fetch-field "mime-version") - (progn - (widen) - (insert "MIME-Version: 1.0\n"))) - (widen))) - -; Encodes a file PATH with COMMAND, leaving the result in the -; current buffer. -(defun gnus-uu-post-encode-file (command path file-name) - (= 0 (call-process "sh" nil t nil "-c" - (format "%s %s %s" command path file-name)))) - -(defun gnus-uu-post-news-inews () - "Posts the composed news article and encoded file. -If no file has been included, the user will be asked for a file." - (interactive) - (if (not (eq (current-buffer) (get-buffer gnus-post-news-buffer))) - (error "Not in post news buffer")) - - (let (file-name) - - (if gnus-uu-post-inserted-file-name - (setq file-name gnus-uu-post-inserted-file-name) - (setq file-name (gnus-uu-post-insert-binary))) - - (if gnus-uu-post-threaded - (let ((gnus-required-headers - (if (memq 'Message-ID gnus-required-headers) - gnus-required-headers - (cons 'Message-ID gnus-required-headers))) - gnus-inews-article-hook elem) - - (setq gnus-inews-article-hook (if (listp gnus-inews-article-hook) - gnus-inews-article-hook - (list gnus-inews-article-hook))) - (setq gnus-inews-article-hook - (cons - '(lambda () - (save-excursion - (goto-char 1) - (if (re-search-forward "^Message-ID: \\(.*\\)$" nil t) - (setq gnus-uu-post-message-id - (buffer-substring - (match-beginning 1) (match-end 1))) - (setq gnus-uu-post-message-id nil)))) - gnus-inews-article-hook)) - (gnus-uu-post-encoded file-name t)) - (gnus-uu-post-encoded file-name nil))) - (setq gnus-uu-post-inserted-file-name nil) - (and gnus-uu-winconf-post-news - (set-window-configuration gnus-uu-winconf-post-news))) - -; Asks for a file to encode, encodes it and inserts the result in -; the current buffer. Returns the file name the user gave. -(defun gnus-uu-post-insert-binary () - (let ((uuencode-buffer-name "*uuencode buffer*") - file-path post-buf uubuf file-name) - - (setq file-path (read-file-name - "What file do you want to encode? ")) - (if (not (file-exists-p file-path)) - (error "%s: No such file" file-path)) - - (goto-char (point-max)) - (insert (format "\n%s\n" gnus-uu-post-binary-separator)) - - (if (string-match "^~/" file-path) - (setq file-path (concat "$HOME" (substring file-path 1)))) - (if (string-match "/[^/]*$" file-path) - (setq file-name (substring file-path (1+ (match-beginning 0)))) - (setq file-name file-path)) - - (unwind-protect - (if (save-excursion - (set-buffer (setq uubuf - (get-buffer-create uuencode-buffer-name))) - (erase-buffer) - (funcall gnus-uu-post-encode-method file-path file-name)) - (insert-buffer uubuf) - (error "Encoding unsuccessful")) - (kill-buffer uubuf)) - file-name)) - -; Posts the article and all of the encoded file. -(defun gnus-uu-post-encoded (file-name &optional threaded) - (let ((send-buffer-name "*uuencode send buffer*") - (encoded-buffer-name "*encoded buffer*") - (top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]") - (separator (concat mail-header-separator "\n\n")) - file uubuf length parts header i end beg - beg-line minlen buf post-buf whole-len beg-binary end-binary) - - (setq post-buf (current-buffer)) - - (goto-char 1) - (if (not (re-search-forward - (if gnus-uu-post-separate-description - gnus-uu-post-binary-separator - mail-header-separator) nil t)) - (error "Internal error: No binary/header separator")) - (beginning-of-line) - (forward-line 1) - (setq beg-binary (point)) - (setq end-binary (point-max)) - - (save-excursion - (set-buffer (setq uubuf (get-buffer-create encoded-buffer-name))) - (erase-buffer) - (insert-buffer-substring post-buf beg-binary end-binary) - (goto-char 1) - (setq length (count-lines 1 (point-max))) - (setq parts (/ length gnus-uu-post-length)) - (if (not (< (% length gnus-uu-post-length) 4)) - (setq parts (1+ parts)))) - - (if gnus-uu-post-separate-description - (forward-line -1)) - (kill-region (point) (point-max)) - - (goto-char 1) - (search-forward mail-header-separator nil t) - (beginning-of-line) - (setq header (buffer-substring 1 (point))) - - (goto-char 1) - (if (not gnus-uu-post-separate-description) - () - (if (and (not threaded) (re-search-forward "^Subject: " nil t)) - (progn - (end-of-line) - (insert (format " (0/%d)" parts)))) - (gnus-inews-news)) - - (save-excursion - (setq i 1) - (setq beg 1) - (while (not (> i parts)) - (set-buffer (get-buffer-create send-buffer-name)) - (erase-buffer) - (insert header) - (if (and threaded gnus-uu-post-message-id) - (insert (format "References: %s\n" gnus-uu-post-message-id))) - (insert separator) - (setq whole-len - (- 62 (length (format top-string "" file-name i parts "")))) - (if (> 1 (setq minlen (/ whole-len 2))) - (setq minlen 1)) - (setq - beg-line - (format top-string - (make-string minlen ?-) - file-name i parts - (make-string - (if (= 0 (% whole-len 2)) (1- minlen) minlen) ?-))) - - (goto-char 1) - (if (not (re-search-forward "^Subject: " nil t)) - () - (if (not threaded) - (progn - (end-of-line) - (insert (format " (%d/%d)" i parts))) - (if (or (and (= i 2) gnus-uu-post-separate-description) - (and (= i 1) (not gnus-uu-post-separate-description))) - (replace-match "Subject: Re: ")))) - - (goto-char (point-max)) - (save-excursion - (set-buffer uubuf) - (goto-char beg) - (if (= i parts) - (goto-char (point-max)) - (forward-line gnus-uu-post-length)) - (if (and (= (1+ i) parts) (< (count-lines (point) (point-max)) 4)) - (forward-line -4)) - (setq end (point))) - (insert-buffer-substring uubuf beg end) - (insert beg-line) - (insert "\n") - (setq beg end) - (setq i (1+ i)) - (goto-char 1) - (re-search-forward mail-header-separator nil t) - (beginning-of-line) - (forward-line 2) - (if (re-search-forward gnus-uu-post-binary-separator nil t) - (progn - (replace-match "") - (forward-line 1))) - (insert beg-line) - (insert "\n") - (gnus-inews-news))) - - (and (setq buf (get-buffer send-buffer-name)) - (kill-buffer buf)) - (and (setq buf (get-buffer encoded-buffer-name)) - (kill-buffer buf)) - - (if (not gnus-uu-post-separate-description) - (progn - (set-buffer-modified-p nil) - (and (fboundp 'bury-buffer) (bury-buffer)))))) - -(provide 'gnus-uu) - -;; gnus-uu.el ends here
--- a/lisp/=gnus.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7243 +0,0 @@ -;;; gnus.el --- NNTP-based News Reader for GNU Emacs -;; Copyright (C) 1987,88,89,90,93,94,95 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; Keywords: news - -;; 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: - -;; How to Install GNUS: -;; (0) First of all, remove GNUS related OLD *.elc files (at least -;; nntp.elc). -;; (1) Unshar gnus.el, gnuspost.el, gnusmail.el, gnusmisc.el, and -;; nntp.el. -;; (2) byte-compile-file nntp.el, gnus.el, gnuspost.el, gnusmail.el, -;; and gnusmisc.el. If you have a local news spool, -;; byte-compile-file nnspool.el, too. -;; (3) Define three environment variables in .login file as follows: -;; -;; setenv NNTPSERVER flab -;; setenv DOMAINNAME "stars.flab.Fujitsu.CO.JP" -;; setenv ORGANIZATION "Fujitsu Laboratories Ltd., Kawasaki, Japan." -;; -;; Or instead, define lisp variables in your .emacs, site-init.el, -;; or default.el as follows: -;; -;; (setq gnus-nntp-server "flab") -;; (setq gnus-local-domain "stars.flab.Fujitsu.CO.JP") -;; (setq gnus-local-organization "Fujitsu Laboratories Ltd., ...") -;; -;; If the function (system-name) returns the full internet name, -;; you don't have to define the domain. -;; -;; (4) You may have to define NNTP service name as number 119. -;; -;; (setq gnus-nntp-service 119) -;; -;; Or, if you'd like to use a local news spool directly in stead -;; of NNTP, set the variable to nil as follows: -;; -;; (setq gnus-nntp-service nil) -;; -;; (5) If you'd like to use the GENERICFROM feature like the Bnews, -;; define the variable as follows: -;; -;; (setq gnus-use-generic-from t) -;; -;; (6) Define autoload entries in .emacs file as follows: -;; -;; (autoload 'gnus "gnus" "Read network news." t) -;; (autoload 'gnus-post-news "gnuspost" "Post a news." t) -;; -;; (7) Read nntp.el if you have problems with NNTP or kanji handling. -;; -;; (8) Install mhspool.el, tcp.el, and tcp.c if it is necessary. -;; -;; mhspool.el is a package for reading articles or mail in your -;; private directory using GNUS. -;; -;; tcp.el and tcp.c are necessary if and only if your Emacs does -;; not have the function `open-network-stream' which is used for -;; communicating with NNTP server inside Emacs. -;; -;; (9) Install an Info file generated from the texinfo manual gnus.texinfo. -;; -;; If you are not allowed to create the Info file to the standard -;; Info-directory, create it in your private directory and set the -;; variable gnus-info-directory to that directory. -;; -;; For getting more information about GNUS, consult USENET newsgorup -;; gnu.emacs.gnus. - -;; TO DO: -;; (1) Incremental update of active info. -;; (2) Asynchronous transmission of large messages. - -;;; Code: - -(require 'nntp) -(require 'mail-utils) -(require 'timezone) - -(defvar gnus-default-nntp-server nil - "*Specify default NNTP server. -This variable should be defined in `site-init.el'.") - -(defvar gnus-nntp-server (or (getenv "NNTPSERVER") gnus-default-nntp-server) - "*The name of the host running NNTP server. -If it is a string starting with a colon, as in as `:DIRECTORY', then the -directory ~/DIRECTORY is used as the news spool. -This variable is initialized from the NNTPSERVER environment variable -or from `gnus-default-nntp-server'.") - -(defvar gnus-nntp-service "nntp" - "*NNTP service name (\"nntp\" or 119). -Go to a local news spool if its value is nil.") - -(defvar gnus-startup-file "~/.newsrc" - "*Your `.newsrc' file. Use `.newsrc-SERVER' instead if exists.") - -(defvar gnus-signature-file "~/.signature" - "*Your `.signature' file. Use `.signature-DISTRIBUTION' instead if exists.") - -(defvar gnus-use-cross-reference t - "*Specifies what to do with cross references (Xref: field). -If nil, ignore cross references. If t, mark articles as read in -subscribed newsgroups. Otherwise, if not nil nor t, mark articles as -read in all newsgroups.") - -(defvar gnus-use-followup-to t - "*Specifies what to do with Followup-To: field. -If nil, ignore `Followup-to:' field. If t, use its value except for -`poster'. Otherwise, if not nil nor t, always use its value.") - -(defvar gnus-large-newsgroup 50 - "*The number of articles which indicates a large newsgroup. -If the number of articles in a newsgroup is greater than the value, -confirmation is required for selecting the newsgroup.") - -(defvar gnus-author-copy (getenv "AUTHORCOPY") - "*File name saving a copy of an article posted using FCC: field. -Initialized from the AUTHORCOPY environment variable. - -Articles are saved using a function specified by the the variable -`gnus-author-copy-saver' (`rmail-output' is default) if a file name is -given. Instead, if the first character of the name is `|', the -contents of the article is piped out to the named program. It is -possible to save an article in an MH folder as follows: - -\(setq gnus-author-copy \"|/usr/local/lib/mh/rcvstore +Article\")") - -(defvar gnus-author-copy-saver (function rmail-output) - "*A function called with a file name to save an author copy to. -The default function is `rmail-output' which saves in inbox format.") - -(defvar gnus-use-long-file-name - (not (memq system-type '(usg-unix-v xenix))) - "*Non-nil means that a newsgroup name is used as a default file name -to save articles to. If it's nil, the directory form of a newsgroup is -used instead.") - -(defvar gnus-article-save-directory (getenv "SAVEDIR") - "*A directory name to save articles to (default is `~/News'). -Initialized from the SAVEDIR environment variable.") - -(defvar gnus-kill-files-directory (getenv "SAVEDIR") - "*A directory name to save kill files to (default to ~/News). -Initialized from the SAVEDIR environment variable.") - -(defvar gnus-default-article-saver (function gnus-summary-save-in-rmail) - "*A function to save articles in your favorite format. -The function must be interactively callable (in other words, it must -be an Emacs command). - -GNUS provides the following functions: - gnus-summary-save-in-rmail (in Rmail format) - gnus-summary-save-in-mail (in Unix mail format) - gnus-summary-save-in-folder (in an MH folder) - gnus-summary-save-in-file (in article format).") - -(defvar gnus-rmail-save-name (function gnus-plain-save-name) - "*A function generating a file name to save articles in Rmail format. -The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE.") - -(defvar gnus-mail-save-name (function gnus-plain-save-name) - "*A function generating a file name to save articles in Unix mail format. -The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE.") - -(defvar gnus-folder-save-name (function gnus-folder-save-name) - "*A function generating a file name to save articles in MH folder. -The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER.") - -(defvar gnus-file-save-name (function gnus-numeric-save-name) - "*A function generating a file name to save articles in article format. -The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE.") - -(defvar gnus-kill-file-name "KILL" - "*File name of a KILL file.") - -(defvar gnus-novice-user t - "*Non-nil means that you are a novice to USENET. -If non-nil, verbose messages may be displayed -or your confirmations may be required.") - -(defvar gnus-interactive-catchup t - "*Require your confirmation when catching up a newsgroup if non-nil.") - -(defvar gnus-interactive-post t - "*Newsgroup, subject, and distribution will be asked for if non-nil.") - -(defvar gnus-interactive-exit t - "*Require your confirmation when exiting GNUS if non-nil.") - -(defvar gnus-user-login-name nil - "*The login name of the user. -Got from the function `user-login-name' if undefined.") - -(defvar gnus-user-full-name nil - "*The full name of the user. -Got from the NAME environment variable if undefined.") - -(defvar gnus-show-mime nil - "*Show MIME message if non-nil.") - -(defvar gnus-show-threads t - "*Show conversation threads in Summary Mode if non-nil.") - -(defvar gnus-thread-hide-subject t - "*Non-nil means hide subjects for thread subtrees.") - -(defvar gnus-thread-hide-subtree nil - "*Non-nil means hide thread subtrees initially. -If non-nil, you have to run the command `gnus-summary-show-thread' by -hand or by using `gnus-select-article-hook' to show hidden threads.") - -(defvar gnus-thread-hide-killed t - "*Non-nil means hide killed thread subtrees automatically.") - -(defvar gnus-thread-ignore-subject nil - "*Don't take care of subject differences, but only references if non-nil. -If it is non-nil, some commands work with subjects do not work properly.") - -(defvar gnus-thread-indent-level 4 - "*Indentation of thread subtrees.") - -(defvar gnus-ignored-newsgroups "^to\\..*$" - "*A regexp to match uninteresting newsgroups in the active file. -Any lines in the active file matching this regular expression are -removed from the newsgroup list before anything else is done to it, -thus making them effectively invisible.") - -(defvar gnus-ignored-headers - "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:" - "*Header fields not worth displaying. -Ordinarily GNUS excludes these when displaying an article. -If you want to see them, ask to see the message with \"the full header\" -\(also known as \"the original header\").") - -(defvar gnus-required-headers - '(From Date Newsgroups Subject Message-ID Path Organization Distribution) - "*All required fields for articles you post. -RFC977 and RFC1036 require From, Date, Newsgroups, Subject, Message-ID -and Path fields. Organization, Distribution and Lines are optional. -If you want GNUS not to insert some field, remove it from this list.") - -(defvar gnus-show-all-headers nil - "*Show all headers of an article if non-nil.") - -(defvar gnus-save-all-headers t - "*Save all headers of an article if non-nil.") - -(defvar gnus-optional-headers (function gnus-optional-lines-and-from) - "*A function generating a optional string displayed in GNUS Summary -mode buffer. The function is called with an article HEADER. The -result must be a string excluding `[' and `]'.") - -(defvar gnus-auto-extend-newsgroup t - "*Extend visible articles to forward and backward if non-nil.") - -(defvar gnus-auto-select-first t - "*Select the first unread article automagically if non-nil. -If you want to prevent automatic selection of the first unread article -in some newsgroups, set the variable to nil in `gnus-select-group-hook' -or `gnus-apply-kill-hook'.") - -(defvar gnus-auto-select-next t - "*Select the next newsgroup automagically if non-nil. -If the value is t and the next newsgroup is empty, GNUS will exit -Summary mode and go back to Group mode. If the value is neither nil -nor t, GNUS will select the following unread newsgroup. Especially, if -the value is the symbol `quietly', the next unread newsgroup will be -selected without any confirmations.") - -(defvar gnus-auto-select-same nil - "*Select the next article with the same subject automagically if non-nil.") - -(defvar gnus-auto-center-summary t - "*Always center the current summary in GNUS Summary window if non-nil.") - -(defvar gnus-auto-mail-to-author nil - "*Insert `To: author' of the article when following up if non-nil. -Mail is sent using the function specified by the variable -`gnus-mail-send-method'.") - -(defvar gnus-break-pages t - "*Break an article into pages if non-nil. -Page delimiter is specified by the variable `gnus-page-delimiter'.") - -(defvar gnus-page-delimiter "^\^L" - "*Regexp describing line-beginnings that separate pages of news article.") - -(defvar gnus-digest-show-summary t - "*Show a summary of undigestified messages if non-nil.") - -(defvar gnus-digest-separator "^Subject:[ \t]" - "*Regexp that separates messages in a digest article.") - -(defvar gnus-use-full-window t - "*Non-nil means to take up the entire screen of Emacs.") - -(defvar gnus-window-configuration - '((summary (0 1 0)) - (newsgroups (1 0 0)) - (article (0 3 10))) - "*Specify window configurations for each action. -The format of the variable is a list of (ACTION (G S A)), where G, S, -and A are the relative height of Group, Summary, and Article windows, -respectively. ACTION is `summary', `newsgroups', or `article'.") - -(defvar gnus-show-mime-method (function metamail-buffer) - "*Function to process a MIME message. -The function is expected to process current buffer as a MIME message.") - -(defvar gnus-mail-reply-method - (function gnus-mail-reply-using-mail) - "*Function to compose reply mail. -The function `gnus-mail-reply-using-mail' uses usual sendmail mail -program. The function `gnus-mail-reply-using-mhe' uses the MH-E mail -program. You can use yet another program by customizing this variable.") - -(defvar gnus-mail-forward-method - (function gnus-mail-forward-using-mail) - "*Function to forward current message to another user. -The function `gnus-mail-reply-using-mail' uses usual sendmail mail -program. You can use yet another program by customizing this variable.") - -(defvar gnus-mail-other-window-method - (function gnus-mail-other-window-using-mail) - "*Function to compose mail in other window. -The function `gnus-mail-other-window-using-mail' uses the usual sendmail -mail program. The function `gnus-mail-other-window-using-mhe' uses the MH-E -mail program. You can use yet another program by customizing this variable.") - -(defvar gnus-mail-send-method send-mail-function - "*Function to mail a message too which is being posted as an article. -The message must have To: or Cc: field. The default is copied from -the variable `send-mail-function'.") - -(defvar gnus-subscribe-newsgroup-method - (function gnus-subscribe-alphabetically) - "*Function called with a newsgroup name when new newsgroup is found. -The function `gnus-subscribe-randomly' inserts a new newsgroup a the -beginning of newsgroups. The function `gnus-subscribe-alphabetically' -inserts it in strict alphabetic order. The function -`gnus-subscribe-hierarchically' inserts it in hierarchical newsgroup -order. The function `gnus-subscribe-interactively' asks for your decision.") - -(defvar gnus-group-mode-hook nil - "*A hook for GNUS Group Mode.") - -(defvar gnus-summary-mode-hook nil - "*A hook for GNUS Summary Mode.") - -(defvar gnus-article-mode-hook nil - "*A hook for GNUS Article Mode.") - -(defvar gnus-kill-file-mode-hook nil - "*A hook for GNUS KILL File Mode.") - -(defvar gnus-open-server-hook nil - "*A hook called just before opening connection to news server.") - -(defvar gnus-startup-hook nil - "*A hook called at start up time. -This hook is called after GNUS is connected to the NNTP server. So, it -is possible to change the behavior of GNUS according to the selected -NNTP server.") - -(defvar gnus-group-prepare-hook nil - "*A hook called after newsgroup list is created in the Newsgroup buffer. -If you want to modify the Newsgroup buffer, you can use this hook.") - -(defvar gnus-summary-prepare-hook nil - "*A hook called after summary list is created in the Summary buffer. -If you want to modify the Summary buffer, you can use this hook.") - -(defvar gnus-article-prepare-hook nil - "*A hook called after an article is prepared in the Article buffer. -If you want to run a special decoding program like nkf, use this hook.") - -(defvar gnus-select-group-hook nil - "*A hook called when a newsgroup is selected. -If you want to sort Summary buffer by date and then by subject, you -can use the following hook: - -\(add-hook 'gnus-select-group-hook - (function - (lambda () - ;; First of all, sort by date. - (gnus-keysort-headers - (function string-lessp) - (function - (lambda (a) - (gnus-sortable-date (gnus-header-date a))))) - ;; Then sort by subject string ignoring `Re:'. - ;; If case-fold-search is non-nil, case of letters is ignored. - (gnus-keysort-headers - (function string-lessp) - (function - (lambda (a) - (if case-fold-search - (downcase (gnus-simplify-subject (gnus-header-subject a) t)) - (gnus-simplify-subject (gnus-header-subject a) t))))) - ))) - -If you'd like to simplify subjects like the -`gnus-summary-next-same-subject' command does, you can use the -following hook: - -\(add-hook 'gnus-select-group-hook - (function - (lambda () - (mapcar (function - (lambda (header) - (nntp-set-header-subject - header - (gnus-simplify-subject - (gnus-header-subject header) 're-only)))) - gnus-newsgroup-headers)))) - -In some newsgroups author name is meaningless. It is possible to -prevent listing author names in GNUS Summary buffer as follows: - -\(add-hook 'gnus-select-group-hook - (function - (lambda () - (cond ((string-equal \"comp.sources.unix\" gnus-newsgroup-name) - (setq gnus-optional-headers - (function gnus-optional-lines))) - (t - (setq gnus-optional-headers - (function gnus-optional-lines-and-from)))))))") - -(defvar gnus-select-article-hook - '(gnus-summary-show-thread) - "*A hook called when an article is selected. -The default hook shows conversation thread subtrees of the selected -article automatically using `gnus-summary-show-thread'. - -If you'd like to run Rmail on a digest article automagically, you can -use the following hook: - -\(add-hook 'gnus-select-article-hook - (function - (lambda () - (cond ((string-equal \"comp.sys.sun\" gnus-newsgroup-name) - (gnus-summary-rmail-digest)) - ((and (string-equal \"comp.text\" gnus-newsgroup-name) - (string-match \"^TeXhax Digest\" - (gnus-header-subject gnus-current-headers))) - (gnus-summary-rmail-digest) - )))) - t)") - -(defvar gnus-select-digest-hook - (list - (function - (lambda () - ;; Reply-To: is required by `undigestify-rmail-message'. - (or (mail-position-on-field "Reply-to" t) - (progn - (mail-position-on-field "Reply-to") - (insert (gnus-fetch-field "From"))))))) - "*A hook called when reading digest messages using Rmail. -This hook can be used to modify incomplete digest articles as follows -\(this is the default): - -\(add-hook 'gnus-select-digest-hook - (function - (lambda () - ;; Reply-To: is required by `undigestify-rmail-message'. - (or (mail-position-on-field \"Reply-to\" t) - (progn - (mail-position-on-field \"Reply-to\") - (insert (gnus-fetch-field \"From\")))))))") - -(defvar gnus-rmail-digest-hook nil - "*A hook called when reading digest messages using Rmail. -This hook is intended to customize Rmail mode for reading digest articles.") - -(defvar gnus-apply-kill-hook '(gnus-apply-kill-file) - "*A hook called when a newsgroup is selected and summary list is prepared. -This hook is intended to apply a KILL file to the selected newsgroup. -The function `gnus-apply-kill-file' is called by default. - -Since a general KILL file is too heavy to use only for a few -newsgroups, I recommend you to use a lighter hook function. For -example, if you'd like to apply a KILL file to articles which contains -a string `rmgroup' in subject in newsgroup `control', you can use the -following hook: - -\(setq gnus-apply-kill-hook - (list - (function - (lambda () - (cond ((string-match \"control\" gnus-newsgroup-name) - (gnus-kill \"Subject\" \"rmgroup\") - (gnus-expunge \"X\")))))))") - -(defvar gnus-mark-article-hook - (list - (function - (lambda () - (or (memq gnus-current-article gnus-newsgroup-marked) - (gnus-summary-mark-as-read gnus-current-article)) - (gnus-summary-set-current-mark "+")))) - "*A hook called when an article is selected at the first time. -The hook is intended to mark an article as read (or unread) -automatically when it is selected. - -If you'd like to mark as unread (-) instead, use the following hook: - -\(setq gnus-mark-article-hook - (list - (function - (lambda () - (gnus-summary-mark-as-unread gnus-current-article) - (gnus-summary-set-current-mark \"+\")))))") - -(defvar gnus-prepare-article-hook (list (function gnus-inews-insert-signature)) - "*A hook called after preparing body, but before preparing header fields. -The default hook (`gnus-inews-insert-signature') inserts a signature -file specified by the variable `gnus-signature-file'.") - -(defvar gnus-inews-article-hook (list (function gnus-inews-do-fcc)) - "*A hook called before finally posting an article. -The default hook (`gnus-inews-do-fcc') does FCC processing (save article -to a file).") - -(defvar gnus-exit-group-hook nil - "*A hook called when exiting (not quitting) Summary mode. -If your machine is so slow that exiting from Summary mode takes very -long time, set the variable `gnus-use-cross-reference' to nil. This -inhibits marking articles as read using cross-reference information.") - -(defvar gnus-suspend-gnus-hook nil - "*A hook called when suspending (not exiting) GNUS.") - -(defvar gnus-exit-gnus-hook nil - "*A hook called when exiting (not suspending) GNUS.") - -(defvar gnus-save-newsrc-hook nil - "*A hook called when saving the newsrc file. -This hook is called before saving the `.newsrc' file.") - - -;; Site dependent variables. You have to define these variables in -;; site-init.el, default.el or your .emacs. - -(defvar gnus-local-timezone nil - "*Local time zone. -This value is used only if `current-time-zone' does not work in your Emacs. -It specifies the GMT offset, i.e. a decimal integer -of the form +-HHMM giving the hours and minutes ahead of (i.e. east of) GMT. -For example, +0900 should be used in Japan, since it is 9 hours ahead of GMT. - -For backwards compatibility, it may also be a string like \"JST\", -but strings are obsolescent: you should use numeric offsets instead.") - -(defvar gnus-local-domain nil - "*Local domain name without a host name like: \"stars.flab.Fujitsu.CO.JP\" -The `DOMAINNAME' environment variable is used instead if defined. If -the function (system-name) returns the full internet name, there is no -need to define the name.") - -(defvar gnus-local-organization nil - "*Local organization like: \"Fujitsu Laboratories Ltd., Kawasaki, Japan.\" -The `ORGANIZATION' environment variable is used instead if defined.") - -(defvar gnus-local-distributions '("local" "world") - "*List of distributions. -The first element in the list is used as default. If distributions -file is available, its content is also used.") - -(defvar gnus-use-generic-from nil - "*If nil, prepend local host name to the defined domain in the From: -field; if a string, use this; if non-nil, strip off the local host name.") - -(defvar gnus-use-generic-path nil - "*If nil, use the NNTP server name in the Path: field; if stringp, -use this; if non-nil, use no host name (user name only)") - -(defvar gnus-newsgroups-regex "^\\([^ \t\n]+\\)[ \t]+\\(.*\\)$" - "Regex to retrieve the group name and the group description from -the output of the newsgroups listing. - -If you have ^M at the end of lines try \"^\\([^ \t\n]+\\)[ \t]+\\([^\r]+\\)[\r]*$\"") - -(defvar gnus-newsgroups-display t - "*display the newsgroup description in *Newsgroup* buffer if not nil") - -(defvar gnus-newsgroups-alist nil - "alist (groupname . description)") - -(defvar gnus-newsgroups-hashtb nil - "hashtable of gnus-newsgroups-alist") - -(defvar gnus-newsgroups-showall nil - "non nil if we display all the groups") - - -;; Internal variables. - -(defconst gnus-version "GNUS 4.1" - "Version numbers of this version of GNUS.") - -(defconst gnus-emacs-version - (progn - (string-match "[0-9]*" emacs-version) - (string-to-int (substring emacs-version - (match-beginning 0) (match-end 0)))) - "Major version number of this emacs.") - -(defvar gnus-info-nodes - '((gnus-group-mode "(gnus)Newsgroup Commands") - (gnus-summary-mode "(gnus)Summary Commands") - (gnus-article-mode "(gnus)Article Commands") - (gnus-kill-file-mode "(gnus)Kill File") - (gnus-browse-killed-mode "(gnus)Maintaining Subscriptions")) - "Assoc list of major modes and related Info nodes.") - -;; Alist syntax is different from that of 3.14.3. -(defvar gnus-access-methods - '((nntp - (gnus-retrieve-headers nntp-retrieve-headers) - (gnus-open-server nntp-open-server) - (gnus-close-server nntp-close-server) - (gnus-server-opened nntp-server-opened) - (gnus-status-message nntp-status-message) - (gnus-request-article nntp-request-article) - (gnus-request-group nntp-request-group) - (gnus-request-list nntp-request-list) - (gnus-request-list-newsgroups nntp-request-list-newsgroups) - (gnus-request-list-distributions nntp-request-list-distributions) - (gnus-request-post nntp-request-post)) - (nnspool - (gnus-retrieve-headers nnspool-retrieve-headers) - (gnus-open-server nnspool-open-server) - (gnus-close-server nnspool-close-server) - (gnus-server-opened nnspool-server-opened) - (gnus-status-message nnspool-status-message) - (gnus-request-article nnspool-request-article) - (gnus-request-group nnspool-request-group) - (gnus-request-list nnspool-request-list) - (gnus-request-list-newsgroups nnspool-request-list-newsgroups) - (gnus-request-list-distributions nnspool-request-list-distributions) - (gnus-request-post nnspool-request-post)) - (mhspool - (gnus-retrieve-headers mhspool-retrieve-headers) - (gnus-open-server mhspool-open-server) - (gnus-close-server mhspool-close-server) - (gnus-server-opened mhspool-server-opened) - (gnus-status-message mhspool-status-message) - (gnus-request-article mhspool-request-article) - (gnus-request-group mhspool-request-group) - (gnus-request-list mhspool-request-list) - (gnus-request-list-newsgroups mhspool-request-list-newsgroups) - (gnus-request-list-distributions mhspool-request-list-distributions) - (gnus-request-post mhspool-request-post))) - "Access method for NNTP, nnspool, and mhspool.") - -(defvar gnus-group-buffer "*Newsgroup*") -(defvar gnus-summary-buffer "*Summary*") -(defvar gnus-article-buffer "*Article*") -(defvar gnus-digest-buffer "GNUS Digest") -(defvar gnus-digest-summary-buffer "GNUS Digest-summary") - -(defvar gnus-buffer-list - (list gnus-group-buffer gnus-summary-buffer gnus-article-buffer - gnus-digest-buffer gnus-digest-summary-buffer) - "GNUS buffer names which should be killed when exiting.") - -(defvar gnus-variable-list - '(gnus-newsrc-options - gnus-newsrc-options-n-yes gnus-newsrc-options-n-no - gnus-newsrc-assoc gnus-killed-assoc gnus-marked-assoc) - "GNUS variables saved in the quick startup file.") - -(defvar gnus-overload-functions - '((news-inews gnus-inews-news "rnewspost") - (caesar-region gnus-caesar-region "rnews")) - "Functions overloaded by gnus. -It is a list of `(original overload &optional file)'.") - -(defvar gnus-distribution-list nil) - -(defvar gnus-newsrc-options nil - "Options line in the `.newsrc' file.") - -(defvar gnus-newsrc-options-n-yes nil - "Regexp representing subscribed newsgroups.") - -(defvar gnus-newsrc-options-n-no nil - "Regexp representing unsubscribed newsgroups.") - -(defvar gnus-newsrc-assoc nil - "Assoc list of read articles. -`gnus-newsrc-hashtb' should be kept so that both hold the same information.") - -(defvar gnus-newsrc-hashtb nil - "Hashtable of `gnus-newsrc-assoc'.") - -(defvar gnus-killed-assoc nil - "Assoc list of newsgroups removed from `gnus-newsrc-assoc'. -`gnus-killed-hashtb' should be kept so that both hold the same information.") - -(defvar gnus-killed-hashtb nil - "Hashtable of `gnus-killed-assoc'.") - -(defvar gnus-marked-assoc nil - "Assoc list of articles marked as unread. -`gnus-marked-hashtb' should be kept so that both hold the same information.") - -(defvar gnus-marked-hashtb nil - "Hashtable of `gnus-marked-assoc'.") - -(defvar gnus-unread-hashtb nil - "Hashtable of unread articles.") - -(defvar gnus-active-hashtb nil - "Hashtable of active articles.") - -(defvar gnus-octive-hashtb nil - "Hashtable of OLD active articles.") - -(defvar gnus-current-startup-file nil - "Startup file for the current host.") - -(defvar gnus-last-search-regexp nil - "Default regexp for article search command.") - -(defvar gnus-last-shell-command nil - "Default shell command on article.") - -(defvar gnus-have-all-newsgroups nil) - -(defvar gnus-newsgroup-name nil) -(defvar gnus-newsgroup-begin nil) -(defvar gnus-newsgroup-end nil) -(defvar gnus-newsgroup-last-rmail nil) -(defvar gnus-newsgroup-last-mail nil) -(defvar gnus-newsgroup-last-folder nil) -(defvar gnus-newsgroup-last-file nil) - -(defvar gnus-newsgroup-unreads nil - "List of unread articles in the current newsgroup.") - -(defvar gnus-newsgroup-unselected nil - "List of unselected unread articles in the current newsgroup.") - -(defvar gnus-newsgroup-marked nil - "List of marked articles in the current newsgroup (a subset of unread art).") - -(defvar gnus-newsgroup-headers nil - "List of article headers in the current newsgroup. -If you modify the variable, you must call the function -`gnus-clear-hashtables-for-newsgroup-headers' to clear the hash tables.") -(defvar gnus-newsgroup-headers-hashtb-by-id nil) -(defvar gnus-newsgroup-headers-hashtb-by-number nil) - -(defvar gnus-current-article nil) -(defvar gnus-current-headers nil) -(defvar gnus-current-history nil) -(defvar gnus-have-all-headers nil "Must be either T or NIL.") -(defvar gnus-last-article nil) -(defvar gnus-current-kill-article nil) - -;; Save window configuration. -(defvar gnus-winconf-kill-file nil) - -(defvar gnus-group-mode-map nil) -(defvar gnus-summary-mode-map nil) -(defvar gnus-article-mode-map nil) -(defvar gnus-kill-file-mode-map nil) - -(defvar rmail-default-file (expand-file-name "~/XMBOX")) -(defvar rmail-default-rmail-file (expand-file-name "~/XNEWS")) - -;; Define GNUS Subsystems. -(autoload 'gnus-group-post-news "gnuspost" - "Post an article." t) -(autoload 'gnus-summary-post-news "gnuspost" - "Post an article." t) -(autoload 'gnus-summary-followup "gnuspost" - "Post a reply article." t) -(autoload 'gnus-summary-followup-with-original "gnuspost" - "Post a reply article with original article." t) -(autoload 'gnus-summary-cancel-article "gnuspost" - "Cancel an article you posted." t) - -(autoload 'gnus-summary-reply "gnusmail" - "Reply mail to news author." t) -(autoload 'gnus-summary-reply-with-original "gnusmail" - "Reply mail to news author with original article." t) -(autoload 'gnus-summary-mail-forward "gnusmail" - "Forward the current message to another user." t) -(autoload 'gnus-summary-mail-other-window "gnusmail" - "Compose mail in other window." t) - -(autoload 'gnus-group-kill-group "gnusmisc" - "Kill newsgroup on current line." t) -(autoload 'gnus-group-yank-group "gnusmisc" - "Yank the last killed newsgroup on current line." t) -(autoload 'gnus-group-kill-region "gnusmisc" - "Kill newsgroups in current region." t) -(autoload 'gnus-group-transpose-groups "gnusmisc" - "Exchange current newsgroup and previous newsgroup." t) -(autoload 'gnus-list-killed-groups "gnusmisc" - "List the killed newsgroups." t) -(autoload 'gnus-gmt-to-local "gnusmisc" - "Rewrite Date field in GMT to local in current buffer.") - -(autoload 'metamail-buffer "metamail" - "Process current buffer through `metamail'." t) - -(autoload 'rmail-output "rmailout" - "Append this message to Unix mail file named FILE-NAME." t) -(autoload 'mail-position-on-field "sendmail") -(autoload 'mh-find-path "mh-e") -(autoload 'mh-prompt-for-folder "mh-e") - -(put 'gnus-group-mode 'mode-class 'special) -(put 'gnus-summary-mode 'mode-class 'special) -(put 'gnus-article-mode 'mode-class 'special) - -(autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap) -(autoload 'gnus-uu-mark-article "gnus-uu" nil t) - -;;(put 'gnus-eval-in-buffer-window 'lisp-indent-hook 1) - -(defmacro gnus-eval-in-buffer-window (buffer &rest forms) - "Pop to BUFFER, evaluate FORMS, and then returns to original window." - (` (let ((GNUSStartBufferWindow (selected-window))) - (unwind-protect - (progn - (pop-to-buffer (, buffer)) - (,@ forms)) - (select-window GNUSStartBufferWindow))))) - -(defmacro gnus-make-hashtable (&optional hashsize) - "Make a hash table (default and minimum size is 200). -Optional argument HASHSIZE specifies the table size." - (` (make-vector (, (if hashsize (` (max (, hashsize) 200)) 200)) 0))) - -(defmacro gnus-gethash (string hashtable) - "Get hash value of STRING in HASHTABLE." - ;;(` (symbol-value (abbrev-symbol (, string) (, hashtable)))) - ;;(` (abbrev-expansion (, string) (, hashtable))) - (` (symbol-value (intern-soft (, string) (, hashtable))))) - -(defmacro gnus-sethash (string value hashtable) - "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." - ;; We cannot use define-abbrev since it only accepts string as value. - (` (set (intern (, string) (, hashtable)) (, value)))) - -;; Note: Macros defined here are also defined in nntp.el. I don't like -;; to put them here, but many users got troubled with the old -;; definitions in nntp.elc. These codes are NNTP 3.10 version. - -(defmacro nntp-header-number (header) - "Return article number in HEADER." - (` (aref (, header) 0))) - -(defmacro nntp-set-header-number (header number) - "Set article number of HEADER to NUMBER." - (` (aset (, header) 0 (, number)))) - -(defmacro nntp-header-subject (header) - "Return subject string in HEADER." - (` (aref (, header) 1))) - -(defmacro nntp-set-header-subject (header subject) - "Set article subject of HEADER to SUBJECT." - (` (aset (, header) 1 (, subject)))) - -(defmacro nntp-header-from (header) - "Return author string in HEADER." - (` (aref (, header) 2))) - -(defmacro nntp-set-header-from (header from) - "Set article author of HEADER to FROM." - (` (aset (, header) 2 (, from)))) - -(defmacro nntp-header-xref (header) - "Return xref string in HEADER." - (` (aref (, header) 3))) - -(defmacro nntp-set-header-xref (header xref) - "Set article xref of HEADER to xref." - (` (aset (, header) 3 (, xref)))) - -(defmacro nntp-header-lines (header) - "Return lines in HEADER." - (` (aref (, header) 4))) - -(defmacro nntp-set-header-lines (header lines) - "Set article lines of HEADER to LINES." - (` (aset (, header) 4 (, lines)))) - -(defmacro nntp-header-date (header) - "Return date in HEADER." - (` (aref (, header) 5))) - -(defmacro nntp-set-header-date (header date) - "Set article date of HEADER to DATE." - (` (aset (, header) 5 (, date)))) - -(defmacro nntp-header-id (header) - "Return Id in HEADER." - (` (aref (, header) 6))) - -(defmacro nntp-set-header-id (header id) - "Set article Id of HEADER to ID." - (` (aset (, header) 6 (, id)))) - -(defmacro nntp-header-references (header) - "Return references in HEADER." - (` (aref (, header) 7))) - -(defmacro nntp-set-header-references (header ref) - "Set article references of HEADER to REF." - (` (aset (, header) 7 (, ref)))) - - -;;; -;;; GNUS Group Mode -;;; - -(if gnus-group-mode-map - nil - (setq gnus-group-mode-map (make-keymap)) - (suppress-keymap gnus-group-mode-map) - (define-key gnus-group-mode-map " " 'gnus-group-read-group) - (define-key gnus-group-mode-map "=" 'gnus-group-select-group) - (define-key gnus-group-mode-map "j" 'gnus-group-jump-to-group) - (define-key gnus-group-mode-map "n" 'gnus-group-next-unread-group) - (define-key gnus-group-mode-map "p" 'gnus-group-prev-unread-group) - (define-key gnus-group-mode-map "\177" 'gnus-group-prev-unread-group) - (define-key gnus-group-mode-map "N" 'gnus-group-next-group) - (define-key gnus-group-mode-map "P" 'gnus-group-prev-group) - (define-key gnus-group-mode-map "\C-n" 'gnus-group-next-group) - (define-key gnus-group-mode-map "\C-p" 'gnus-group-prev-group) - (define-key gnus-group-mode-map [down] 'gnus-group-next-group) - (define-key gnus-group-mode-map [up] 'gnus-group-prev-group) - (define-key gnus-group-mode-map "\r" 'next-line) - ;;(define-key gnus-group-mode-map "/" 'isearch-forward) - (define-key gnus-group-mode-map "<" 'beginning-of-buffer) - (define-key gnus-group-mode-map ">" 'end-of-buffer) - (define-key gnus-group-mode-map "u" 'gnus-group-unsubscribe-current-group) - (define-key gnus-group-mode-map "U" 'gnus-group-unsubscribe-group) - (define-key gnus-group-mode-map "c" 'gnus-group-catchup) - (define-key gnus-group-mode-map "C" 'gnus-group-catchup-all) - (define-key gnus-group-mode-map "l" 'gnus-group-list-groups) - (define-key gnus-group-mode-map "L" 'gnus-group-list-all-groups) - (define-key gnus-group-mode-map "g" 'gnus-group-get-new-news) - (define-key gnus-group-mode-map "R" 'gnus-group-restart) - (define-key gnus-group-mode-map "b" 'gnus-group-check-bogus-groups) - (define-key gnus-group-mode-map "r" 'gnus-group-restrict-groups) - (define-key gnus-group-mode-map "a" 'gnus-group-post-news) - (define-key gnus-group-mode-map "\ek" 'gnus-group-edit-local-kill) - (define-key gnus-group-mode-map "\eK" 'gnus-group-edit-global-kill) - (define-key gnus-group-mode-map "\C-k" 'gnus-group-kill-group) - (define-key gnus-group-mode-map "\C-y" 'gnus-group-yank-group) - (define-key gnus-group-mode-map "\C-w" 'gnus-group-kill-region) - (define-key gnus-group-mode-map "\C-x\C-t" 'gnus-group-transpose-groups) - (define-key gnus-group-mode-map "\C-c\C-l" 'gnus-list-killed-groups) - (define-key gnus-group-mode-map "V" 'gnus-version) - ;;(define-key gnus-group-mode-map "x" 'gnus-group-force-update) - (define-key gnus-group-mode-map "s" 'gnus-group-force-update) - (define-key gnus-group-mode-map "z" 'gnus-group-suspend) - (define-key gnus-group-mode-map "q" 'gnus-group-exit) - (define-key gnus-group-mode-map "Q" 'gnus-group-quit) - (define-key gnus-group-mode-map "?" 'gnus-group-describe-briefly) - (define-key gnus-group-mode-map "\C-c\C-i" 'gnus-info-find-node) - (define-key gnus-group-mode-map [mouse-2] 'gnus-mouse-pick-group) - (define-key gnus-group-mode-map "t" 'gnus-newsgroups-display-toggle) - - ;; Make a menu bar item. - (define-key gnus-group-mode-map [menu-bar GNUS] - (cons "GNUS" (make-sparse-keymap "GNUS"))) - - (define-key gnus-group-mode-map [menu-bar GNUS force-update] - '("Force Update" . gnus-group-force-update)) - (define-key gnus-group-mode-map [menu-bar GNUS quit] - '("Quit" . gnus-group-quit)) - (define-key gnus-group-mode-map [menu-bar GNUS exit] - '("Exit" . gnus-group-exit)) - (define-key gnus-group-mode-map [menu-bar GNUS restart] - '("Restart" . gnus-group-restart)) - (define-key gnus-group-mode-map [menu-bar GNUS suspend] - '("Suspend" . gnus-group-suspend)) - (define-key gnus-group-mode-map [menu-bar GNUS get-new-news] - '("Get New News" . gnus-group-get-new-news)) - - ;; Make a menu bar item. - (define-key gnus-group-mode-map [menu-bar groups] - (cons "Groups" (make-sparse-keymap "Groups"))) - - (define-key gnus-group-mode-map [menu-bar groups catchup] - '("Catchup" . gnus-group-catchup)) - (define-key gnus-group-mode-map [menu-bar groups edit-global-kill] - '("Edit Kill File" . gnus-group-edit-global-kill)) - - (define-key gnus-group-mode-map [menu-bar groups separator-2] - '("--")) - - (define-key gnus-group-mode-map [menu-bar groups yank-group] - '("Yank Group" . gnus-group-yank-group)) - (define-key gnus-group-mode-map [menu-bar groups kill-group] - '("Kill Group" . gnus-group-kill-group)) - - (define-key gnus-group-mode-map [menu-bar groups separator-1] - '("--")) - - (define-key gnus-group-mode-map [menu-bar groups newsgroups-update-description] - '("Update descriptions" . gnus-newsgroups-update-description)) - (define-key gnus-group-mode-map [menu-bar groups newsgroups-display-toggle] - '("Toggle descriptions" . gnus-newsgroups-display-toggle)) - (define-key gnus-group-mode-map [menu-bar groups jump-to-group] - '("Jump to Group..." . gnus-group-jump-to-group)) - (define-key gnus-group-mode-map [menu-bar groups list-all-groups] - '("List All Groups" . gnus-group-list-all-groups)) - (define-key gnus-group-mode-map [menu-bar groups list-groups] - '("List Groups" . gnus-group-list-groups)) - (define-key gnus-group-mode-map [menu-bar groups unsub-current-group] - '("Unsubscribe Group" . gnus-group-unsubscribe-current-group)) - ) - -(defun gnus-group-mode () - "Major mode for reading network news. -All normal editing commands are turned off. -Instead, these commands are available: - -SPC Read articles in this newsgroup. -= Select this newsgroup. -j Move to the specified newsgroup. -n Move to the next unread newsgroup. -p Move to the previous unread newsgroup. -C-n Move to the next newsgroup. -C-p Move to the previous newsgroup. -< Move point to the beginning of this buffer. -> Move point to the end of this buffer. -u Unsubscribe from (subscribe to) this newsgroup. -U Unsubscribe from (subscribe to) the specified newsgroup. -c Mark all articles as read, preserving marked articles. -C Mark all articles in this newsgroup as read. -l Revert this buffer. -L List all newsgroups. -g Get new news. -R Force to read the raw .newsrc file and get new news. -b Check bogus newsgroups. -r Restrict visible newsgroups to the current region. -a Post a new article. -ESC k Edit a local KILL file applied to this newsgroup. -ESC K Edit a global KILL file applied to all newsgroups. -C-k Kill this newsgroup. -C-y Yank killed newsgroup here. -C-w Kill newsgroups in current region (excluding current point). -C-x C-t Exchange this newsgroup and previous newsgroup. -C-c C-l list killed newsgroups. -s Save .newsrc file. -z Suspend reading news. -q Quit reading news. -Q Quit reading news without saving .newsrc file. -V Show the version number of this GNUS. -? Describe Group Mode commands briefly. -C-h m Describe Group Mode. -C-c C-i Read Info about Group Mode. -t Toggle displaying newsgroup descriptions. - - The name of the host running NNTP server is asked for if no default -host is specified. It is also possible to choose another NNTP server -even when the default server is defined by giving a prefix argument to -the command `\\[gnus]'. - - If the NNTP server name starts with a colon, as in `:Mail', the user's -own directory `~/Mail' is used as a news spool. This makes it -possible to read mail stored in MH folders or articles saved by GNUS. -File names of mail or articles must consist of only numeric -characters. Otherwise, they are ignored. - - If there is a file named `~/.newsrc-SERVER', it is used as the -startup file instead of standard one when talking to SERVER. It is -possible to talk to many hosts by using different startup files for -each. - - Option `-n' of the options line in the startup file is recognized -properly the same as the Bnews system. For example, if the options -line is `options -n !talk talk.rumors', newsgroups under the `talk' -hierarchy except for `talk.rumors' are ignored while checking new -newsgroups. - - If there is a file named `~/.signature-DISTRIBUTION', it is used as -signature file instead of standard one when posting a news in -DISTRIBUTION. - - If an Info file generated from `gnus.texinfo' is installed, you can -read an appropriate Info node of the Info file according to the -current major mode of GNUS by \\[gnus-info-find-node]. - - The variable `gnus-version', `nntp-version', `nnspool-version', and -`mhspool-version' have the version numbers of this version of gnus.el, -nntp.el, nnspool.el, and mhspoo.el, respectively. - -User customizable variables: - gnus-nntp-server - Specifies the name of the host running the NNTP server. If its - value is a string such as `:DIRECTORY', the user's private - DIRECTORY is used as a news spool. The variable is initialized - from the NNTPSERVER environment variable. - - gnus-nntp-service - Specifies a NNTP service name. It is usually \"nntp\" or 119. - Nil forces GNUS to use a local news spool if the variable - `gnus-nntp-server' is set to the local host name. - - gnus-startup-file - Specifies a startup file (.newsrc). If there is a file named - `.newsrc-SERVER', it's used instead when talking to SERVER. I - recommend you to use the server specific file, if you'd like to - talk to many servers. Especially if you'd like to read your - private directory, the name of the file must be - `.newsrc-:DIRECTORY'. - - gnus-signature-file - Specifies a signature file (.signature). If there is a file named - `.signature-DISTRIBUTION', it's used instead when posting an - article in DISTRIBUTION. Set the variable to nil to prevent - appending the file automatically. If you use an NNTP inews which - comes with the NNTP package, you may have to set the variable to - nil. - - gnus-use-cross-reference - Specifies what to do with cross references (Xref: field). If it - is nil, cross references are ignored. If it is t, articles in - subscribed newsgroups are only marked as read. Otherwise, if it - is not nil nor t, articles in all newsgroups are marked as read. - - gnus-use-followup-to - Specifies what to do with followup-to: field. If it is nil, its - value is ignored. If it is non-nil, its value is used as followup - newsgroups. Especially, if it is t and field value is `poster', - your confirmation is required. - - gnus-author-copy - Specifies a file name to save a copy of article you posted using - FCC: field. If the first character of the value is `|', the - contents of the article is piped out to a program specified by the - rest of the value. The variable is initialized from the - AUTHORCOPY environment variable. - - gnus-author-copy-saver - Specifies a function to save an author copy. The function is - called with a file name. The default function `rmail-output' - saves in Unix mail format. - - gnus-kill-file-name - Use specified file name as a KILL file (default to `KILL'). - - gnus-novice-user - Non-nil means that you are a novice to USENET. If non-nil, - verbose messages may be displayed or your confirmations may be - required. - - gnus-interactive-post - Non-nil means that newsgroup, subject and distribution are asked - for interactively when posting a new article. - - gnus-use-full-window - Non-nil means to take up the entire screen of Emacs. - - gnus-window-configuration - Specifies the configuration of Group, Summary, and Article - windows. It is a list of (ACTION (G S A)), where G, S, and A are - the relative height of Group, Summary, and Article windows, - respectively. ACTION is `summary', `newsgroups', or `article'. - - gnus-subscribe-newsgroup-method - Specifies a function called with a newsgroup name when new - newsgroup is found. The default definition adds new newsgroup at - the beginning of other newsgroups. - - And more and more. Please refer to texinfo documentation. - -Various hooks for customization: - gnus-group-mode-hook - Entry to this mode calls the value with no arguments, if that - value is non-nil. This hook is called before GNUS is connected to - the NNTP server. So, you can change or define the NNTP server in - this hook. - - gnus-startup-hook - Called with no arguments after the NNTP server is selected. It is - possible to change the behavior of GNUS or initialize the - variables according to the selected NNTP server. - - gnus-group-prepare-hook - Called with no arguments after a newsgroup list is created in the - Newsgroup buffer, if that value is non-nil. - - gnus-save-newsrc-hook - Called with no arguments when saving newsrc file if that value is - non-nil. - - gnus-prepare-article-hook - Called with no arguments after preparing message body, but before - preparing header fields which is automatically generated if that - value is non-nil. The default hook (gnus-inews-insert-signature) - inserts a signature file. - - gnus-inews-article-hook - Called with no arguments when posting an article if that value is - non-nil. This hook is called just before posting an article. The - default hook does FCC (save an article to the specified file). - - gnus-suspend-gnus-hook - Called with no arguments when suspending (not exiting) GNUS, if - that value is non-nil. - - gnus-exit-gnus-hook - Called with no arguments when exiting (not suspending) GNUS, if - that value is non-nil." - (interactive) - (kill-all-local-variables) - ;; Gee. Why don't you upgrade? - (cond ((boundp 'mode-line-modified) - (setq mode-line-modified "--- ")) - ((listp (default-value 'mode-line-format)) - (setq mode-line-format - (cons "--- " (cdr (default-value 'mode-line-format))))) - (t - (setq mode-line-format - "--- GNUS: List of Newsgroups %[(%m)%]----%3p-%-"))) - (setq major-mode 'gnus-group-mode) - (setq mode-name "Newsgroup") - (setq mode-line-buffer-identification "GNUS: List of Newsgroups") - (setq mode-line-process nil) - (use-local-map gnus-group-mode-map) - (buffer-flush-undo (current-buffer)) - (setq buffer-read-only t) ;Disable modification - (setq truncate-lines t) ;In case descriptions are too long. - (run-hooks 'gnus-group-mode-hook)) - -(defun gnus-mouse-pick-group (e) - (interactive "e") - (mouse-set-point e) - (gnus-group-read-group nil)) - -;;;###autoload -(defun gnus (&optional confirm) - "Read network news. -If optional argument CONFIRM is non-nil, ask NNTP server." - (interactive "P") - (unwind-protect - (progn - (switch-to-buffer (get-buffer-create gnus-group-buffer)) - (gnus-group-mode) - (gnus-start-news-server confirm)) - (if (not (gnus-server-opened)) - (gnus-group-quit) - ;; NNTP server is successfully open. - (setq mode-line-process (format " {%s}" gnus-nntp-server)) - (let ((buffer-read-only nil)) - (erase-buffer) - (gnus-group-startup-message) - (sit-for 0)) - (run-hooks 'gnus-startup-hook) - (gnus-setup-news) - (if gnus-novice-user - (gnus-group-describe-briefly)) ;Show brief help message. - (gnus-group-list-groups nil) - ))) - -(defun gnus-group-startup-message () - "Insert startup message in current buffer." - ;; Insert the message. - (insert - (format " - %s - - NNTP-based News Reader for GNU Emacs - - -If you have any trouble with this software, please let me -know. I will fix your problems in the next release. - -Comments, suggestions, and bug fixes are welcome. - -Masanobu UMEDA -umerin@mse.kyutech.ac.jp" gnus-version)) - ;; And then hack it. - ;; 57 is the longest line. - (indent-rigidly (point-min) (point-max) (/ (max (- (window-width) 57) 0) 2)) - (goto-char (point-min)) - ;; +4 is fuzzy factor. - (insert-char ?\n (/ (max (- (window-height) 18) 0) 2))) - -(defun gnus-group-list-groups (show-all) - "List newsgroups in the Newsgroup buffer. -If argument SHOW-ALL is non-nil, unsubscribed groups are also listed." - (interactive "P") - (setq gnus-newsgroups-showall show-all) - (let ((case-fold-search nil) - (last-group ;Current newsgroup. - (gnus-group-group-name)) - (next-group ;Next possible newsgroup. - (progn - (gnus-group-search-forward nil nil) - (gnus-group-group-name))) - (prev-group ;Previous possible newsgroup. - (progn - (gnus-group-search-forward t nil) - (gnus-group-group-name)))) - (set-buffer gnus-group-buffer) ;May call from out of Group buffer - (gnus-group-prepare show-all) - (if (zerop (buffer-size)) - (message "No news is good news") - ;; Go to last newsgroup if possible. If cannot, try next and - ;; previous. If all fail, go to first unread newsgroup. - (goto-char (point-min)) - (or (and last-group - (re-search-forward (gnus-group-make-regexp last-group) nil t)) - (and next-group - (re-search-forward (gnus-group-make-regexp next-group) nil t)) - (and prev-group - (re-search-forward (gnus-group-make-regexp prev-group) nil t)) - (gnus-group-search-forward nil nil t)) - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - ))) - -(defun gnus-group-prepare (&optional all) - "Prepare list of newsgroups in current buffer. -If optional argument ALL is non-nil, unsubscribed groups are also listed." - (let ((buffer-read-only nil) - (newsrc gnus-newsrc-assoc) - (group-info nil) - (group-name nil) - (group-description nil) - (unread-count 0) - (nb-tab 0) - ;; This specifies the format of Group buffer. - (cntl "%s%s%5d: %s")) - (erase-buffer) - ;; List newsgroups. - (while newsrc - (setq group-info (car newsrc)) - (setq group-name (car group-info)) - (if gnus-newsgroups-display - (progn (setq group-description (gnus-gethash group-name gnus-newsgroups-hashtb)) - (setq nb-tab (/ (- 38 (length group-name)) tab-width)))) - (setq unread-count (nth 1 (gnus-gethash group-name gnus-unread-hashtb))) - (if (or all - (and (nth 1 group-info) ;Subscribed. - (> unread-count 0))) ;There are unread articles. - ;; Yes, I can use gnus-group-prepare-line, but this is faster. - (insert - (format (concat cntl (make-string (if (> nb-tab 0) nb-tab 1) ?\t) - "%s\n") - ;; Subscribed or not. - (if (nth 1 group-info) " " "U") - ;; Has new news? - (if (and (> unread-count 0) - (>= 0 - (- unread-count - (length - (cdr (gnus-gethash group-name - gnus-marked-hashtb)))))) - "*" " ") - ;; Number of unread articles. - unread-count - ;; Newsgroup name. - group-name - ;; Newsgroup description - (if group-description (cdr group-description) "") - )) - ) - (setq newsrc (cdr newsrc)) - ) - (setq gnus-have-all-newsgroups all) - (goto-char (point-min)) - (run-hooks 'gnus-group-prepare-hook) - )) - -(defun gnus-group-prepare-line (info) - "Return a string for the Newsgroup buffer from INFO. -INFO is an element of `gnus-newsrc-assoc' or `gnus-killed-assoc'." - (let* ((group-name (car info)) - (group-description nil) - (nb-tab 0) - (unread-count - (or (nth 1 (gnus-gethash group-name gnus-unread-hashtb)) - ;; Not in hash table, so compute it now. - (gnus-number-of-articles - (gnus-difference-of-range - (nth 2 (gnus-gethash group-name gnus-active-hashtb)) - (nthcdr 2 info))))) - ;; This specifies the format of Group buffer. - (cntl "%s%s%5d: %s")) - (if gnus-newsgroups-display - (progn - (setq group-description (gnus-gethash group-name gnus-newsgroups-hashtb)) - (setq nb-tab (/ (- 38 (length group-name)) tab-width)))) - (format (concat cntl (make-string (if (> nb-tab 0) nb-tab 1) ?\t) - "%s\n") - ;; Subscribed or not. - (if (nth 1 info) " " "U") - ;; Has new news? - (if (and (> unread-count 0) - (>= 0 - (- unread-count - (length - (cdr (gnus-gethash group-name - gnus-marked-hashtb)))))) - "*" " ") - ;; Number of unread articles. - unread-count - ;; Newsgroup name. - group-name - ;; Newsgroup description - (if group-description (cdr group-description) "") - ))) - -(defun gnus-group-update-group (group &optional visible-only) - "Update newsgroup info of GROUP. -If optional argument VISIBLE-ONLY is non-nil, non displayed group is ignored." - (let ((buffer-read-only nil) - (case-fold-search nil) ;appleIIgs vs. appleiigs - (regexp (gnus-group-make-regexp group)) - (visible nil)) - ;; Buffer may be narrowed. - (save-restriction - (widen) - ;; Search a line to modify. If the buffer is large, the search - ;; takes long time. In most cases, current point is on the line - ;; we are looking for. So, first of all, check current line. - ;; And then if current point is in the first half, search from - ;; the beginning. Otherwise, search from the end. - (if (cond ((progn - (beginning-of-line) - (looking-at regexp))) - ((and (> (/ (buffer-size) 2) (point)) ;In the first half. - (progn - (goto-char (point-min)) - (re-search-forward regexp nil t)))) - ((progn - (goto-char (point-max)) - (re-search-backward regexp nil t)))) - ;; GROUP is listed in current buffer. So, delete old line. - (progn - (setq visible t) - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point))) - ) - ;; No such line in the buffer, so insert it at the top. - (goto-char (point-min))) - (if (or visible (not visible-only)) - (progn - (insert (gnus-group-prepare-line - (gnus-gethash group gnus-newsrc-hashtb))) - (forward-line -1) ;Move point on that line. - )) - ))) - -(defun gnus-group-group-name () - "Get newsgroup name around point." - (save-excursion - (beginning-of-line) - (if (looking-at "^..[0-9 \t]+:[ \t]+\\([^ \t\n]+\\)\\([ \t].*\\|$\\)") - (let ((group-name (buffer-substring (match-beginning 1) (match-end 1)))) - (set-text-properties 0 (length group-name) nil group-name) - group-name)))) - -(defun gnus-group-make-regexp (newsgroup) - "Return regexp that matches for a line of NEWSGROUP." - (concat "^.+: " (regexp-quote newsgroup) "\\([ \t].*\\|$\\)")) - -(defun gnus-group-search-forward (backward norest &optional heretoo) - "Search for the next (or previous) newsgroup. -If 1st argument BACKWARD is non-nil, search backward instead. -If 2nd argument NOREST is non-nil, don't care about newsgroup property. -If optional argument HERETOO is non-nil, current line is searched for, too." - (let ((case-fold-search nil) - (func - (if backward - (function re-search-backward) (function re-search-forward))) - (regexp - (format "^%s[ \t]*\\(%s\\):" - (if norest ".." " [ \t]") - (if norest "[0-9]+" "[1-9][0-9]*"))) - (found nil)) - (if backward - (if heretoo - (end-of-line) - (beginning-of-line)) - (if heretoo - (beginning-of-line) - (end-of-line))) - (setq found (funcall func regexp nil t)) - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - ;; Return T if found. - found - )) - -;; GNUS Group mode command - -(defun gnus-group-read-group (all &optional no-article) - "Read news in this newsgroup. -If argument ALL is non-nil, already read articles become readable. -If optional argument NO-ARTICLE is non-nil, no article body is displayed." - (interactive "P") - (let ((group (gnus-group-group-name))) ;Newsgroup name to read. - (if group - (gnus-summary-read-group - group - (or all - ;;(not (nth 1 (gnus-gethash group gnus-newsrc-hashtb))) ;Unsubscribed - (zerop - (nth 1 (gnus-gethash group gnus-unread-hashtb)))) ;No unread - no-article - )) - )) - -(defun gnus-group-select-group (all) - "Select this newsgroup. -No article is selected automatically. -If argument ALL is non-nil, already read articles become readable." - (interactive "P") - (gnus-group-read-group all t)) - -(defun gnus-group-jump-to-group (group) - "Jump to newsgroup GROUP." - (interactive - (list (completing-read "Newsgroup: " gnus-newsrc-assoc nil 'require-match))) - (let ((case-fold-search nil)) - (goto-char (point-min)) - (or (re-search-forward (gnus-group-make-regexp group) nil t) - (if (gnus-gethash group gnus-newsrc-hashtb) - ;; Add GROUP entry, then seach again. - (gnus-group-update-group group))) - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - )) - -(defun gnus-group-next-group (n) - "Go to Nth following newsgroup." - (interactive "p") - (while (and (> n 1) - (gnus-group-search-forward nil t)) - (setq n (1- n))) - (or (gnus-group-search-forward nil t) - (message "No more newsgroups"))) - -(defun gnus-group-next-unread-group (n) - "Go to Nth following unread newsgroup." - (interactive "p") - (while (and (> n 1) - (gnus-group-search-forward nil nil)) - (setq n (1- n))) - (or (gnus-group-search-forward nil nil) - (message "No more unread newsgroups"))) - -(defun gnus-group-prev-group (n) - "Go to Nth previous newsgroup." - (interactive "p") - (while (and (> n 1) - (gnus-group-search-forward t t)) - (setq n (1- n))) - (or (gnus-group-search-forward t t) - (message "No more newsgroups"))) - -(defun gnus-group-prev-unread-group (n) - "Go to Nth previous unread newsgroup." - (interactive "p") - (while (and (> n 1) - (gnus-group-search-forward t nil)) - (setq n (1- n))) - (or (gnus-group-search-forward t nil) - (message "No more unread newsgroups"))) - -(defun gnus-group-catchup (all) - "Mark all articles not marked as unread in current newsgroup as read. -If prefix argument ALL is non-nil, all articles are marked as read. -Cross references (Xref: field) of articles are ignored." - (interactive "P") - (let* ((group (gnus-group-group-name)) - (marked (if (not all) - (cdr (gnus-gethash group gnus-marked-hashtb))))) - (and group - (or (not gnus-interactive-catchup) ;Without confirmation? - (y-or-n-p - (if all - "Do you really want to mark everything as read? " - "Delete all articles not marked as read? "))) - (progn - (message "") ;Clear "Yes or No" question. - ;; Any marked articles will be preserved. - (gnus-update-unread-articles group marked marked) - (gnus-group-update-group group) - (gnus-group-next-group 1))) - )) - -(defun gnus-group-catchup-all () - "Mark all articles in current newsgroup as read. -Cross references (Xref: field) of articles are ignored." - (interactive) - (gnus-group-catchup t)) - -(defun gnus-group-unsubscribe-current-group () - "Toggle subscribe from/to unsubscribe current group." - (interactive) - (let ((group (gnus-group-group-name))) - (if group - (progn - (gnus-group-unsubscribe-group group) - (gnus-group-next-group 1)) - (message "No Newsgroup found to \(un\)subscribe")))) - -(defun gnus-group-unsubscribe-group (group) - "Toggle subscribe from/to unsubscribe GROUP. -\(If GROUP is new, it is added to `.newsrc' automatically.)" - (interactive - (list (completing-read "Newsgroup: " - gnus-active-hashtb nil 'require-match))) - (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb))) - (cond ((not (null newsrc)) - ;; Toggle subscription flag. - (setcar (nthcdr 1 newsrc) (not (nth 1 newsrc))) - (gnus-update-newsrc-buffer group) - (gnus-group-update-group group) - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t)) - ((and (stringp group) - (gnus-gethash group gnus-active-hashtb)) - ;; Add new newsgroup. - (gnus-add-newsgroup group) - (gnus-group-update-group group) - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t)) - (t (error "No such newsgroup: %s" group))) - )) - -(defun gnus-group-list-all-groups () - "List all of newsgroups in the Newsgroup buffer." - (interactive) - (message "Listing all groups...") - (gnus-group-list-groups t) - (message "Listing all groups...done")) - -(defun gnus-group-get-new-news () - "Get newly arrived articles. In fact, read the active file again." - (interactive) - (gnus-setup-news) - (gnus-group-list-groups gnus-have-all-newsgroups)) - -(defun gnus-group-restart () - "Force GNUS to read the raw startup file." - (interactive) - (gnus-save-newsrc-file) - (gnus-setup-news t) ;Force to read the raw startup file. - (gnus-group-list-groups gnus-have-all-newsgroups)) - -(defun gnus-group-check-bogus-groups () - "Check bogus newsgroups." - (interactive) - (gnus-check-bogus-newsgroups t) ;Require confirmation. - (gnus-group-list-groups gnus-have-all-newsgroups)) - -(defun gnus-group-restrict-groups (start end) - "Restrict visible newsgroups to the current region (START and END). -Type \\[widen] to remove restriction." - (interactive "r") - (save-excursion - (narrow-to-region (progn - (goto-char start) - (beginning-of-line) - (point)) - (progn - (goto-char end) - (forward-line 1) - (point)))) - (message (substitute-command-keys "Type \\[widen] to remove restriction"))) - -(defun gnus-group-edit-global-kill () - "Edit a global KILL file." - (interactive) - (setq gnus-current-kill-article nil) ;No articles selected. - (gnus-kill-file-edit-file nil) ;Nil stands for global KILL file. - (message - (substitute-command-keys - "Editing a global KILL file (Type \\[gnus-kill-file-exit] to exit)"))) - -(defun gnus-group-edit-local-kill () - "Edit a local KILL file." - (interactive) - (setq gnus-current-kill-article nil) ;No articles selected. - (gnus-kill-file-edit-file (gnus-group-group-name)) - (message - (substitute-command-keys - "Editing a local KILL file (Type \\[gnus-kill-file-exit] to exit)"))) - -(defun gnus-group-force-update () - "Update `.newsrc' file." - (interactive) - (gnus-save-newsrc-file)) - -(defun gnus-group-suspend () - "Suspend the current GNUS session. -In fact, cleanup buffers except for Group Mode buffer. -The hook `gnus-suspend-gnus-hook' is called before actually suspending." - (interactive) - (run-hooks 'gnus-suspend-gnus-hook) - ;; Kill GNUS buffers except for Group Mode buffer. - (let ((buffers gnus-buffer-list) - (group-buf (get-buffer gnus-group-buffer))) - (while buffers - (and (not (eq (car buffers) gnus-group-buffer)) - (get-buffer (car buffers)) - (kill-buffer (car buffers))) - (setq buffers (cdr buffers)) - ) - (bury-buffer group-buf) - (delete-windows-on group-buf t))) - -(defun gnus-group-exit () - "Quit reading news after updating `.newsrc'. -The hook `gnus-exit-gnus-hook' is called before actually quitting." - (interactive) - (if (or noninteractive ;For gnus-batch-kill - (zerop (buffer-size)) ;No news is good news. - (not (gnus-server-opened)) ;NNTP connection closed. - (not gnus-interactive-exit) ;Without confirmation - (y-or-n-p "Are you sure you want to quit reading news? ")) - (progn - (message "") ;Erase "Yes or No" question. - (run-hooks 'gnus-exit-gnus-hook) - (gnus-save-newsrc-file) - (gnus-clear-system) - (gnus-close-server)) - )) - -(defun gnus-group-quit () - "Quit reading news without updating `.newsrc'. -The hook `gnus-exit-gnus-hook' is called before actually quitting." - (interactive) - (if (or noninteractive ;For gnus-batch-kill - (zerop (buffer-size)) - (not (gnus-server-opened)) - (yes-or-no-p - (format "Quit reading news without saving %s? " - (file-name-nondirectory gnus-current-startup-file)))) - (progn - (message "") ;Erase "Yes or No" question. - (run-hooks 'gnus-exit-gnus-hook) - (gnus-clear-system) - (gnus-close-server)) - )) - -(defun gnus-group-describe-briefly () - "Describe Group mode commands briefly." - (interactive) - (message - (concat - (substitute-command-keys "\\[gnus-group-read-group]:Select ") - (substitute-command-keys "\\[gnus-group-next-unread-group]:Forward ") - (substitute-command-keys "\\[gnus-group-prev-unread-group]:Backward ") - (substitute-command-keys "\\[gnus-group-exit]:Exit ") - (substitute-command-keys "\\[gnus-info-find-node]:Run Info ") - (substitute-command-keys "\\[gnus-group-describe-briefly]:This help") - ))) - - -;;; -;;; GNUS Summary Mode -;;; - -(if gnus-summary-mode-map - nil - (setq gnus-summary-mode-map (make-keymap)) - (suppress-keymap gnus-summary-mode-map) - (define-key gnus-summary-mode-map "\C-c\C-v" 'gnus-uu-ctl-map) - (define-key gnus-summary-mode-map "#" 'gnus-uu-mark-article) - (define-key gnus-summary-mode-map " " 'gnus-summary-next-page) - (define-key gnus-summary-mode-map "\177" 'gnus-summary-prev-page) - (define-key gnus-summary-mode-map "\r" 'gnus-summary-scroll-up) - (define-key gnus-summary-mode-map "n" 'gnus-summary-next-unread-article) - (define-key gnus-summary-mode-map "p" 'gnus-summary-prev-unread-article) - (define-key gnus-summary-mode-map "N" 'gnus-summary-next-article) - (define-key gnus-summary-mode-map "P" 'gnus-summary-prev-article) - (define-key gnus-summary-mode-map "\e\C-n" 'gnus-summary-next-same-subject) - (define-key gnus-summary-mode-map "\e\C-p" 'gnus-summary-prev-same-subject) - ;;(define-key gnus-summary-mode-map "\e\C-n" 'gnus-summary-next-unread-same-subject) - ;;(define-key gnus-summary-mode-map "\e\C-p" 'gnus-summary-prev-unread-same-subject) - (define-key gnus-summary-mode-map "\C-c\C-n" 'gnus-summary-next-digest) - (define-key gnus-summary-mode-map "\C-c\C-p" 'gnus-summary-prev-digest) - (define-key gnus-summary-mode-map "\C-n" 'gnus-summary-next-subject) - (define-key gnus-summary-mode-map "\C-p" 'gnus-summary-prev-subject) - (define-key gnus-summary-mode-map [down] 'gnus-summary-next-subject) - (define-key gnus-summary-mode-map [up] 'gnus-summary-prev-subject) - (define-key gnus-summary-mode-map "\en" 'gnus-summary-next-unread-subject) - (define-key gnus-summary-mode-map "\ep" 'gnus-summary-prev-unread-subject) - ;;(define-key gnus-summary-mode-map "\C-cn" 'gnus-summary-next-group) - ;;(define-key gnus-summary-mode-map "\C-cp" 'gnus-summary-prev-group) - (define-key gnus-summary-mode-map "." 'gnus-summary-first-unread-article) - ;;(define-key gnus-summary-mode-map "/" 'isearch-forward) - (define-key gnus-summary-mode-map "s" 'gnus-summary-isearch-article) - (define-key gnus-summary-mode-map "\es" 'gnus-summary-search-article-forward) - ;;(define-key gnus-summary-mode-map "\eS" 'gnus-summary-search-article-backward) - (define-key gnus-summary-mode-map "\er" 'gnus-summary-search-article-backward) - (define-key gnus-summary-mode-map "<" 'gnus-summary-beginning-of-article) - (define-key gnus-summary-mode-map ">" 'gnus-summary-end-of-article) - (define-key gnus-summary-mode-map "j" 'gnus-summary-goto-subject) - ;;(define-key gnus-summary-mode-map "J" 'gnus-summary-goto-article) - (define-key gnus-summary-mode-map "l" 'gnus-summary-goto-last-article) - (define-key gnus-summary-mode-map "^" 'gnus-summary-refer-parent-article) - ;;(define-key gnus-summary-mode-map "\er" 'gnus-summary-refer-article) - (define-key gnus-summary-mode-map "\e^" 'gnus-summary-refer-article) - (define-key gnus-summary-mode-map "u" 'gnus-summary-mark-as-unread-forward) - (define-key gnus-summary-mode-map "U" 'gnus-summary-mark-as-unread-backward) - (define-key gnus-summary-mode-map "d" 'gnus-summary-mark-as-read-forward) - (define-key gnus-summary-mode-map "D" 'gnus-summary-mark-as-read-backward) - (define-key gnus-summary-mode-map "\eu" 'gnus-summary-clear-mark-forward) - (define-key gnus-summary-mode-map "\eU" 'gnus-summary-clear-mark-backward) - (define-key gnus-summary-mode-map "k" 'gnus-summary-kill-same-subject-and-select) - (define-key gnus-summary-mode-map "\C-k" 'gnus-summary-kill-same-subject) - (define-key gnus-summary-mode-map "\e\C-t" 'gnus-summary-toggle-threads) - (define-key gnus-summary-mode-map "\e\C-s" 'gnus-summary-show-thread) - (define-key gnus-summary-mode-map "\e\C-h" 'gnus-summary-hide-thread) - (define-key gnus-summary-mode-map "\e\C-f" 'gnus-summary-next-thread) - (define-key gnus-summary-mode-map "\e\C-b" 'gnus-summary-prev-thread) - (define-key gnus-summary-mode-map "\e\C-u" 'gnus-summary-up-thread) - (define-key gnus-summary-mode-map "\e\C-d" 'gnus-summary-down-thread) - (define-key gnus-summary-mode-map "\e\C-k" 'gnus-summary-kill-thread) - (define-key gnus-summary-mode-map "&" 'gnus-summary-execute-command) - ;;(define-key gnus-summary-mode-map "c" 'gnus-summary-catchup) - ;;(define-key gnus-summary-mode-map "c" 'gnus-summary-catchup-all) - (define-key gnus-summary-mode-map "c" 'gnus-summary-catchup-and-exit) - ;;(define-key gnus-summary-mode-map "c" 'gnus-summary-catchup-all-and-exit) - (define-key gnus-summary-mode-map "\C-t" 'gnus-summary-toggle-truncation) - (define-key gnus-summary-mode-map "x" 'gnus-summary-delete-marked-as-read) - (define-key gnus-summary-mode-map "X" 'gnus-summary-delete-marked-with) - (define-key gnus-summary-mode-map "\C-c\C-sn" 'gnus-summary-sort-by-number) - (define-key gnus-summary-mode-map "\C-c\C-sa" 'gnus-summary-sort-by-author) - (define-key gnus-summary-mode-map "\C-c\C-ss" 'gnus-summary-sort-by-subject) - (define-key gnus-summary-mode-map "\C-c\C-sd" 'gnus-summary-sort-by-date) - (define-key gnus-summary-mode-map "\C-c\C-s\C-n" 'gnus-summary-sort-by-number) - (define-key gnus-summary-mode-map "\C-c\C-s\C-a" 'gnus-summary-sort-by-author) - (define-key gnus-summary-mode-map "\C-c\C-s\C-s" 'gnus-summary-sort-by-subject) - (define-key gnus-summary-mode-map "\C-c\C-s\C-d" 'gnus-summary-sort-by-date) - (define-key gnus-summary-mode-map "=" 'gnus-summary-expand-window) - ;;(define-key gnus-summary-mode-map "G" 'gnus-summary-reselect-current-group) - (define-key gnus-summary-mode-map "\C-x\C-s" 'gnus-summary-reselect-current-group) - (define-key gnus-summary-mode-map "w" 'gnus-summary-stop-page-breaking) - (define-key gnus-summary-mode-map "\C-c\C-r" 'gnus-summary-caesar-message) - (define-key gnus-summary-mode-map "g" 'gnus-summary-show-article) - (define-key gnus-summary-mode-map "t" 'gnus-summary-toggle-header) - ;;(define-key gnus-summary-mode-map "v" 'gnus-summary-show-all-headers) - (define-key gnus-summary-mode-map "\et" 'gnus-summary-toggle-mime) - (define-key gnus-summary-mode-map "\C-d" 'gnus-summary-rmail-digest) - (define-key gnus-summary-mode-map "a" 'gnus-summary-post-news) - (define-key gnus-summary-mode-map "f" 'gnus-summary-followup) - (define-key gnus-summary-mode-map "F" 'gnus-summary-followup-with-original) - (define-key gnus-summary-mode-map "C" 'gnus-summary-cancel-article) - (define-key gnus-summary-mode-map "r" 'gnus-summary-reply) - (define-key gnus-summary-mode-map "R" 'gnus-summary-reply-with-original) - (define-key gnus-summary-mode-map "\C-c\C-f" 'gnus-summary-mail-forward) - (define-key gnus-summary-mode-map "m" 'gnus-summary-mail-other-window) - (define-key gnus-summary-mode-map "o" 'gnus-summary-save-article) - (define-key gnus-summary-mode-map "\C-o" 'gnus-summary-save-in-mail) - (define-key gnus-summary-mode-map "|" 'gnus-summary-pipe-output) - (define-key gnus-summary-mode-map "\ek" 'gnus-summary-edit-local-kill) - (define-key gnus-summary-mode-map "\eK" 'gnus-summary-edit-global-kill) - (define-key gnus-summary-mode-map "V" 'gnus-version) - (define-key gnus-summary-mode-map "q" 'gnus-summary-exit) - (define-key gnus-summary-mode-map "Q" 'gnus-summary-quit) - (define-key gnus-summary-mode-map "?" 'gnus-summary-describe-briefly) - (define-key gnus-summary-mode-map "\C-c\C-i" 'gnus-info-find-node) - (define-key gnus-summary-mode-map [mouse-2] 'gnus-mouse-pick-article) - - (define-key gnus-summary-mode-map [menu-bar misc] - (cons "Misc" (make-sparse-keymap "misc"))) - - (define-key gnus-summary-mode-map [menu-bar misc caesar-message] - '("Caesar Message" . gnus-summary-caesar-message)) - (define-key gnus-summary-mode-map [menu-bar misc cancel-article] - '("Cancel Article" . gnus-summary-cancel-article)) - (define-key gnus-summary-mode-map [menu-bar misc edit-local-kill] - '("Edit Kill File" . gnus-summary-edit-local-kill)) - - (define-key gnus-summary-mode-map [menu-bar misc mark-as-unread] - '("Mark as Unread" . gnus-summary-mark-as-unread-forward)) - (define-key gnus-summary-mode-map [menu-bar misc mark-as-read] - '("Mark as Read" . gnus-summary-mark-as-read)) - - (define-key gnus-summary-mode-map [menu-bar misc quit] - '("Quit Group" . gnus-summary-quit)) - (define-key gnus-summary-mode-map [menu-bar misc exit] - '("Exit Group" . gnus-summary-exit)) - - (define-key gnus-summary-mode-map [menu-bar sort] - (cons "Sort" (make-sparse-keymap "sort"))) - - (define-key gnus-summary-mode-map [menu-bar sort sort-by-author] - '("Sort by Author" . gnus-summary-sort-by-author)) - (define-key gnus-summary-mode-map [menu-bar sort sort-by-date] - '("Sort by Date" . gnus-summary-sort-by-date)) - (define-key gnus-summary-mode-map [menu-bar sort sort-by-number] - '("Sort by Number" . gnus-summary-sort-by-number)) - (define-key gnus-summary-mode-map [menu-bar sort sort-by-subject] - '("Sort by Subject" . gnus-summary-sort-by-subject)) - - (define-key gnus-summary-mode-map [menu-bar show/hide] - (cons "Show/Hide" (make-sparse-keymap "show/hide"))) - - (define-key gnus-summary-mode-map [menu-bar show/hide hide-all-threads] - '("Hide All Threads" . gnus-summary-hide-all-threads)) - (define-key gnus-summary-mode-map [menu-bar show/hide hide-thread] - '("Hide Thread" . gnus-summary-hide-thread)) - (define-key gnus-summary-mode-map [menu-bar show/hide show-all-threads] - '("Show All Threads" . gnus-summary-show-all-threads)) - (define-key gnus-summary-mode-map [menu-bar show/hide show-all-headers] - '("Show All Headers" . gnus-summary-show-all-headers)) - (define-key gnus-summary-mode-map [menu-bar show/hide show-thread] - '("Show Thread" . gnus-summary-show-thread)) - (define-key gnus-summary-mode-map [menu-bar show/hide show-article] - '("Show Article" . gnus-summary-show-article)) - (define-key gnus-summary-mode-map [menu-bar show/hide toggle-truncation] - '("Toggle Truncation" . gnus-summary-toggle-truncation)) - (define-key gnus-summary-mode-map [menu-bar show/hide toggle-mime] - '("Toggle Mime" . gnus-summary-toggle-mime)) - (define-key gnus-summary-mode-map [menu-bar show/hide toggle-header] - '("Toggle Header" . gnus-summary-toggle-header)) - - (define-key gnus-summary-mode-map [menu-bar action] - (cons "Action" (make-sparse-keymap "action"))) - - (define-key gnus-summary-mode-map [menu-bar action kill-same-subject] - '("Kill Same Subject" . gnus-summary-kill-same-subject)) - (define-key gnus-summary-mode-map [menu-bar action kill-thread] - '("Kill Thread" . gnus-summary-kill-thread)) - (define-key gnus-summary-mode-map [menu-bar action delete-marked-with] - '("Delete Marked With" . gnus-summary-delete-marked-with)) - (define-key gnus-summary-mode-map [menu-bar action delete-marked-as-read] - '("Delete Marked As Read" . gnus-summary-delete-marked-as-read)) - (define-key gnus-summary-mode-map [menu-bar action catchup-and-exit] - '("Catchup And Exit" . gnus-summary-catchup-and-exit)) - (define-key gnus-summary-mode-map [menu-bar action catchup-to-here] - '("Catchup to Here" . gnus-summary-catchup-to-here)) - - (define-key gnus-summary-mode-map [menu-bar action ignore] - '("---")) - - (define-key gnus-summary-mode-map [menu-bar action save-in-file] - '("Save in File" . gnus-summary-save-in-file)) - (define-key gnus-summary-mode-map [menu-bar action save-article] - '("Save Article" . gnus-summary-save-article)) - - (define-key gnus-summary-mode-map [menu-bar action lambda] - '("---")) - - (define-key gnus-summary-mode-map [menu-bar action forward] - '("Forward" . gnus-summary-mail-forward)) - (define-key gnus-summary-mode-map [menu-bar action followup-with-original] - '("Followup with Original" . gnus-summary-followup-with-original)) - (define-key gnus-summary-mode-map [menu-bar action followup] - '("Followup" . gnus-summary-followup)) - (define-key gnus-summary-mode-map [menu-bar action reply-with-original] - '("Reply with Original" . gnus-summary-reply-with-original)) - (define-key gnus-summary-mode-map [menu-bar action reply] - '("Reply" . gnus-summary-reply)) - (define-key gnus-summary-mode-map [menu-bar action post] - '("Post News" . gnus-summary-post-news)) - - (define-key gnus-summary-mode-map [menu-bar move] - (cons "Move" (make-sparse-keymap "move"))) - - (define-key gnus-summary-mode-map [menu-bar move isearch-article] - '("Search in Article" . gnus-summary-isearch-article)) - (define-key gnus-summary-mode-map [menu-bar move search-through-articles] - '("Search through Articles" . gnus-summary-search-article-forward)) - (define-key gnus-summary-mode-map [menu-bar move down-thread] - '("Down Thread" . gnus-summary-down-thread)) - (define-key gnus-summary-mode-map [menu-bar move prev-same-subject] - '("Prev Same Subject" . gnus-summary-prev-same-subject)) - (define-key gnus-summary-mode-map [menu-bar move prev-group] - '("Prev Group" . gnus-summary-prev-group)) - (define-key gnus-summary-mode-map [menu-bar move next-unread-same-subject] - '("Next Unread Same Subject" . gnus-summary-next-unread-same-subject)) - (define-key gnus-summary-mode-map [menu-bar move next-unread-article] - '("Next Unread Article" . gnus-summary-next-unread-article)) - (define-key gnus-summary-mode-map [menu-bar move next-thread] - '("Next Thread" . gnus-summary-next-thread)) - (define-key gnus-summary-mode-map [menu-bar move next-group] - '("Next Group" . gnus-summary-next-group)) - (define-key gnus-summary-mode-map [menu-bar move first-unread-article] - '("First Unread Article" . gnus-summary-first-unread-article)) - ) - - -(defun gnus-summary-mode () - "Major mode for reading articles in this newsgroup. -All normal editing commands are turned off. -Instead, these commands are available: - -SPC Scroll to the next page of the current article. The next unread - article is selected automatically at the end of the message. -DEL Scroll to the previous page of the current article. -RET Scroll up (or down) one line the current article. -n Move to the next unread article. -p Move to the previous unread article. -N Move to the next article. -P Move to the previous article. -ESC C-n Move to the next article which has the same subject as the - current article. -ESC C-p Move to the previous article which has the same subject as the - current article. -\\[gnus-summary-next-unread-same-subject] - Move to the next unread article which has the same subject as the - current article. -\\[gnus-summary-prev-unread-same-subject] - Move to the previous unread article which has the same subject as - the current article. -C-c C-n Scroll to the next digested message of the current article. -C-c C-p Scroll to the previous digested message of the current article. -C-n Move to the next subject. -C-p Move to the previous subject. -ESC n Move to the next unread subject. -ESC p Move to the previous unread subject. -\\[gnus-summary-next-group] - Exit the current newsgroup and select the next unread newsgroup. -\\[gnus-summary-prev-group] - Exit the current newsgroup and select the previous unread newsgroup. -. Jump to the first unread article in the current newsgroup. -s Do an incremental search forward on the current article. -ESC s Search for an article containing a regexp forward. -ESC r Search for an article containing a regexp backward. -< Move point to the beginning of the current article. -> Move point to the end of the current article. -j Jump to the article specified by the numeric article ID. -l Jump to the article you read last. -^ Refer to parent of the current article. -ESC ^ Refer to the article specified by the Message-ID. -u Mark the current article as unread, and go forward. -U Mark the current article as unread, and go backward. -d Mark the current article as read, and go forward. -D Mark the current article as read, and go backward. -ESC u Clear the current article's mark, and go forward. -ESC U Clear the current article's mark, and go backward. -k Mark articles which has the same subject as the current article as - read, and then select the next unread article. -C-k Mark articles which has the same subject as the current article as - read. -ESC k Edit a local KILL file applied to the current newsgroup. -ESC K Edit a global KILL file applied to all newsgroups. -ESC C-t Toggle showing conversation threads. -ESC C-s Show thread subtrees. -ESC C-h Hide thread subtrees. -\\[gnus-summary-show-all-threads] Show all thread subtrees. -\\[gnus-summary-hide-all-threads] Hide all thread subtrees. -ESC C-f Go to the same level next thread. -ESC C-b Go to the same level previous thread. -ESC C-d Go downward current thread. -ESC C-u Go upward current thread. -ESC C-k Mark articles under current thread as read. -& Execute a command for each article conditionally. -\\[gnus-summary-catchup] - Mark all articles as read in the current newsgroup, preserving - articles marked as unread. -\\[gnus-summary-catchup-all] - Mark all articles as read in the current newsgroup. -\\[gnus-summary-catchup-and-exit] - Catch up all articles not marked as unread, and then exit the - current newsgroup. -\\[gnus-summary-catchup-all-and-exit] - Catch up all articles, and then exit the current newsgroup. -C-t Toggle truncations of subject lines. -x Delete subject lines marked as read. -X Delete subject lines with the specific marks. -C-c C-s C-n Sort subjects by article number. -C-c C-s C-a Sort subjects by article author. -C-c C-s C-s Sort subjects alphabetically. -C-c C-s C-d Sort subjects by date. -= Expand Summary window to show headers full window. -C-x C-s Reselect the current newsgroup. Prefix argument means to select all. -w Stop page breaking by linefeed. -C-c C-r Caesar rotates letters by 13/47 places. -g Force to show the current article. -t Show original article header if pruned header currently shown, or - vice versa. -ESC-t Toggle MIME processing. -C-d Run RMAIL on the current digest article. -a Post a new article. -f Post a reply article. -F Post a reply article with original article. -C Cancel the current article. -r Mail a message to the author. -R Mail a message to the author with original author. -C-c C-f Forward the current message to another user. -m Mail a message in other window. -o Save the current article in your favorite format. -C-o Append the current article to a file in Unix mail format. -| Pipe the contents of the current article to a subprocess. -q Quit reading news in the current newsgroup. -Q Quit reading news without recording unread articles information. -V Show the version number of this GNUS. -? Describe Summary mode commands briefly. -C-h m Describe Summary mode. -C-c C-i Read Info about Summary mode. - -User customizable variables: - gnus-large-newsgroup - The number of articles which indicates a large newsgroup. If the - number of articles in a newsgroup is greater than the value, the - number of articles to be selected is asked for. If the given value - N is positive, the last N articles is selected. If N is negative, - the first N articles are selected. An empty string means to select - all articles. - - gnus-use-long-file-name - Non-nil means that a newsgroup name is used as a default file name - to save articles to. If it's nil, the directory form of a - newsgroup is used instead. - - gnus-default-article-saver - Specifies your favorite article saver which is interactively - funcallable. Following functions are available: - - gnus-summary-save-in-rmail (in Rmail format) - gnus-summary-save-in-mail (in Unix mail format) - gnus-summary-save-in-folder (in MH folder) - gnus-summary-save-in-file (in article format). - - gnus-rmail-save-name - gnus-mail-save-name - gnus-folder-save-name - gnus-file-save-name - Specifies a function generating a file name to save articles in - specified format. The function is called with NEWSGROUP, HEADERS, - and optional LAST-FILE. Access macros to the headers are defined - as `nntp-header-FIELD', and functions are defined as - `gnus-header-FIELD'. - - gnus-article-save-directory - Specifies a directory name to save articles to using the commands - `gnus-summary-save-in-rmail', `gnus-summary-save-in-mail' and - `gnus-summary-save-in-file'. The variable is initialized from the - SAVEDIR environment variable. - - gnus-kill-files-directory - Specifies a directory name to save KILL files to using the commands - `gnus-edit-global-kill', and `gnus-edit-local-kill'. The variable is - initialized from the SAVEDIR environment variable. - - gnus-show-all-headers - Non-nil means that all headers of an article are shown. - - gnus-save-all-headers - Non-nil means that all headers of an article are saved in a file. - - gnus-show-mime - Non-nil means that show a MIME message. - - gnus-show-threads - Non-nil means that conversation threads are shown in tree structure. - - gnus-thread-hide-subject - Non-nil means that subjects for thread subtrees are hidden. - - gnus-thread-hide-subtree - Non-nil means that thread subtrees are hidden initially. - - gnus-thread-hide-killed - Non-nil means that killed thread subtrees are hidden automatically. - - gnus-thread-ignore-subject - Non-nil means that subject differences are ignored in constructing - thread trees. - - gnus-thread-indent-level - Indentation of thread subtrees. - - gnus-optional-headers - Specifies a function which generates an optional string displayed - in the Summary buffer. The function is called with an article - HEADERS. The result must be a string excluding `[' and `]'. The - default function returns a string like NNN:AUTHOR, where NNN is - the number of lines in an article and AUTHOR is the name of the - author. - - gnus-auto-extend-newsgroup - Non-nil means visible articles are extended to forward and - backward automatically if possible. - - gnus-auto-select-first - Non-nil means the first unread article is selected automagically - when a newsgroup is selected normally (by `gnus-group-read-group'). - If you'd like to prevent automatic selection of the first unread - article in some newsgroups, set the variable to nil in - `gnus-select-group-hook' or `gnus-apply-kill-hook'. - - gnus-auto-select-next - Non-nil means the next newsgroup is selected automagically at the - end of the newsgroup. If the value is t and the next newsgroup is - empty (no unread articles), GNUS will exit Summary mode and go - back to Group mode. If the value is neither nil nor t, GNUS won't - exit Summary mode but select the following unread newsgroup. - Especially, if the value is the symbol `quietly', the next unread - newsgroup will be selected without any confirmations. - - gnus-auto-select-same - Non-nil means an article with the same subject as the current - article is selected automagically like `rn -S'. - - gnus-auto-center-summary - Non-nil means the point of Summary Mode window is always kept - centered. - - gnus-break-pages - Non-nil means an article is broken into pages at page delimiters. - This may not work with some versions of GNU Emacs earlier than - version 18.50. - - gnus-page-delimiter - Specifies a regexp describing line-beginnings that separate pages - of news article. - - gnus-digest-show-summary - Non-nil means that a summary of digest messages is shown when - reading a digest article using `gnus-summary-rmail-digest' - command. - - gnus-digest-separator - Specifies a regexp separating messages in a digest article. - - gnus-mail-reply-method - gnus-mail-other-window-method - Specifies a function to begin composing mail message using - commands `gnus-summary-reply' and `gnus-summary-mail-other-window'. - Functions `gnus-mail-reply-using-mail' and `gnus-mail-reply-using-mhe' - are available for the value of `gnus-mail-reply-method'. And - functions `gnus-mail-other-window-using-mail' and - `gnus-mail-other-window-using-mhe' are available for the value of - `gnus-mail-other-window-method'. - - gnus-mail-send-method - Specifies a function to mail a message too which is being posted - as an article. The message must have To: or Cc: field. The value - of the variable `send-mail-function' is the default function, which - uses sendmail mail program. - -Various hooks for customization: - gnus-summary-mode-hook - Entry to this mode calls the value with no arguments, if that - value is non-nil. - - gnus-select-group-hook - Called with no arguments when newsgroup is selected, if that value - is non-nil. It is possible to sort subjects in this hook. See the - documentation of this variable for more information. - - gnus-summary-prepare-hook - Called with no arguments after a summary list is created in the - Summary buffer, if that value is non-nil. If you'd like to modify - the buffer, you can use this hook. - - gnus-select-article-hook - Called with no arguments when an article is selected, if that - value is non-nil. See the documentation of this variable for more - information. - - gnus-select-digest-hook - Called with no arguments when reading digest messages using Rmail, - if that value is non-nil. This hook can be used to modify an - article so that Rmail can work with it. See the documentation of - the variable for more information. - - gnus-rmail-digest-hook - Called with no arguments when reading digest messages using Rmail, - if that value is non-nil. This hook is intended to customize Rmail - mode. - - gnus-apply-kill-hook - Called with no arguments when a newsgroup is selected and the - Summary buffer is prepared. This hook is intended to apply a KILL - file to the selected newsgroup. The format of KILL file is - completely different from that of version 3.8. You have to rewrite - them in the new format. See the documentation of Kill file mode - for more information. - - gnus-mark-article-hook - Called with no arguments when an article is selected at the first - time. The hook is intended to mark an article as read (or unread) - automatically when it is selected. See the documentation of the - variable for more information. - - gnus-exit-group-hook - Called with no arguments when exiting the current newsgroup, if - that value is non-nil. If your machine is so slow that exiting - from Summary mode takes very long time, inhibit marking articles - as read using cross-references by setting the variable - gnus-use-cross-reference to nil in this hook." - (interactive) - (kill-all-local-variables) - ;; Gee. Why don't you upgrade? - (cond ((boundp 'mode-line-modified) - (setq mode-line-modified "--- ")) - ((listp (default-value 'mode-line-format)) - (setq mode-line-format - (cons "--- " (cdr (default-value 'mode-line-format)))))) - ;; To disable display-time facility. - ;;(make-local-variable 'global-mode-string) - ;;(setq global-mode-string nil) - (setq major-mode 'gnus-summary-mode) - (setq mode-name "Summary") - ;;(setq mode-line-process '(" " gnus-newsgroup-name)) - (make-local-variable 'minor-mode-alist) - (or (assq 'gnus-show-threads minor-mode-alist) - (setq minor-mode-alist - (cons (list 'gnus-show-threads " Thread") minor-mode-alist))) - (gnus-summary-set-mode-line) - (use-local-map gnus-summary-mode-map) - (buffer-flush-undo (current-buffer)) - (setq buffer-read-only t) ;Disable modification - (setq truncate-lines t) ;Stop line folding - (setq selective-display t) - (setq selective-display-ellipses t) ;Display `...' - ;;(setq case-fold-search t) - (run-hooks 'gnus-summary-mode-hook)) - -(defun gnus-mouse-pick-article (e) - (interactive "e") - (mouse-set-point e) - (gnus-summary-next-page nil)) - -(defun gnus-summary-setup-buffer () - "Initialize Summary buffer." - (if (get-buffer gnus-summary-buffer) - (set-buffer gnus-summary-buffer) - (set-buffer (get-buffer-create gnus-summary-buffer)) - (gnus-summary-mode) - )) - -(defun gnus-summary-read-group (group &optional show-all no-article) - "Start reading news in newsgroup GROUP. -If optional 1st argument SHOW-ALL is non-nil, already read articles are -also listed. -If optional 2nd argument NO-ARTICLE is non-nil, no article is selected -initially." - (message "Retrieving newsgroup: %s..." group) - (if (gnus-select-newsgroup group show-all) - (progn - ;; Don't switch-to-buffer to prevent displaying old contents - ;; of the buffer until new subjects list is created. - ;; Suggested by Juha Heinanen <jh@tut.fi> - (gnus-summary-setup-buffer) - ;; You can change the order of subjects in this hook. - (run-hooks 'gnus-select-group-hook) - (gnus-summary-prepare) - ;; Function `gnus-apply-kill-file' must be called in this hook. - (run-hooks 'gnus-apply-kill-hook) - (if (zerop (buffer-size)) - ;; This newsgroup is empty. - (progn - (gnus-summary-catchup-and-exit nil t) ;Without confirmations. - (message "No unread news")) - ;; Hide conversation thread subtrees. We cannot do this in - ;; gnus-summary-prepare-hook since kill processing may not - ;; work with hidden articles. - (and gnus-show-threads - gnus-thread-hide-subtree - (gnus-summary-hide-all-threads)) - ;; Show first unread article if requested. - (goto-char (point-min)) - (if (and (not no-article) - gnus-auto-select-first - (gnus-summary-first-unread-article)) - ;; Window is configured automatically. - ;; Current buffer may be changed as a result of hook - ;; evaluation, especially by gnus-summary-rmail-digest - ;; command, so we should adjust cursor point carefully. - (if (eq (current-buffer) (get-buffer gnus-summary-buffer)) - (progn - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t))) - (gnus-configure-windows 'summary) - (pop-to-buffer gnus-summary-buffer) - (gnus-summary-set-mode-line) - ;; I sometime get confused with the old Article buffer. - (if (get-buffer gnus-article-buffer) - (if (get-buffer-window gnus-article-buffer) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil)) - (erase-buffer))) - (kill-buffer gnus-article-buffer))) - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t)) - )) - ;; Cannot select newsgroup GROUP. - (if (gnus-gethash group gnus-active-hashtb) - (progn - ;; If NNTP is used, nntp_access file may not be installed - ;; properly. Otherwise, may be active file problem. - (ding) - (message - (gnus-nntp-message - (format "Cannot select %s. May be security or active file problem." group))) - (sit-for 0)) - ;; Check bogus newsgroups. - ;; We must be in Group Mode buffer. - (gnus-group-check-bogus-groups)) - )) - -(defun gnus-summary-prepare () - "Prepare summary list of current newsgroup in Summary buffer." - (let ((buffer-read-only nil)) - ;; Note: The next codes are not actually used because the user who - ;; want it can define them in gnus-select-group-hook. - ;; Print verbose messages if too many articles are selected. - ;; (and (numberp gnus-large-newsgroup) - ;; (> (length gnus-newsgroup-headers) gnus-large-newsgroup) - ;; (message "Preparing headers...")) - (erase-buffer) - (gnus-summary-prepare-threads - (if gnus-show-threads - (gnus-make-threads gnus-newsgroup-headers) - gnus-newsgroup-headers) 0) - ;; Erase header retrieval message. - (message "") - ;; Call hooks for modifying Summary buffer. - ;; Suggested by sven@tde.LTH.Se (Sven Mattisson). - (goto-char (point-min)) - (run-hooks 'gnus-summary-prepare-hook) - )) - -;; Basic ideas by Paul Dworkin <paul@media-lab.media.mit.edu> -;; Subject bug fix by jbw@bigbird.bu.edu (Joe Wells) - -(defun gnus-summary-prepare-threads (threads level &optional parent-subject) - "Prepare Summary buffer from THREADS and indentation LEVEL. -THREADS is a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...]).' -Optional PARENT-SUBJECT specifies the subject of the parent." - (let ((thread nil) - (header nil) - (number nil) - (subject nil) - (child-subject nil) - (parent-subject (or parent-subject "")) - ;; `M Indent NUM: [OPT] SUBJECT' - (cntl (format "%%s %%s%%%dd: [%%s] %%s\n" - (length (prin1-to-string gnus-newsgroup-end))))) - (while threads - (setq thread (car threads)) - (setq threads (cdr threads)) - ;; If thread is a cons, hierarchical threads is given. - ;; Otherwise, thread itself is header. - (if (consp thread) - (setq header (car thread)) - (setq header thread)) - ;; Print valid header only. - (if (vectorp header) ;Depends on nntp.el. - (progn - (setq number (nntp-header-number header)) - (setq subject (nntp-header-subject header)) - (setq child-subject (gnus-simplify-subject subject 're-only)) - (insert - (format cntl - ;; Read or not. - (cond ((memq number gnus-newsgroup-marked) "-") - ((memq number gnus-newsgroup-unreads) " ") - (t "D")) - ;; Thread level. - (make-string (* level gnus-thread-indent-level) ? ) - ;; Article number. - number - ;; Optional headers. - (or (and gnus-optional-headers - (funcall gnus-optional-headers header)) "") - ;; Its subject string. - (concat (if (or (zerop level) - (not gnus-thread-hide-subject) - ;; Subject is different from the parent. - (not (string-equal - parent-subject child-subject))) - nil - (make-string (window-width) ? )) - subject) - )) - )) - ;; Print subthreads. - (and (consp thread) - (cdr thread) - (gnus-summary-prepare-threads - (cdr thread) (1+ level) child-subject)) - ))) - -;;(defun gnus-summary-set-mode-line () -;; "Set Summary mode line string." -;; ;; The value must be a string to escape %-constructs. -;; (let ((subject -;; (if gnus-current-headers -;; (nntp-header-subject gnus-current-headers) gnus-newsgroup-name))) -;; (setq mode-line-buffer-identification -;; (concat "GNUS: " -;; subject -;; ;; Enough spaces to pad subject to 17 positions. -;; (make-string (max 0 (- 17 (length subject))) ? )))) -;; (set-buffer-modified-p t)) - -;; New implementation in gnus 3.14.3 - -(defun gnus-summary-set-mode-line () - "Set Summary mode line string. -If you don't like it, define your own `gnus-summary-set-mode-line'." - (let ((unmarked - (- (length gnus-newsgroup-unreads) - (length (gnus-intersection - gnus-newsgroup-unreads gnus-newsgroup-marked)))) - (unselected - (- (length gnus-newsgroup-unselected) - (length (gnus-intersection - gnus-newsgroup-unselected gnus-newsgroup-marked))))) - (setq mode-line-buffer-identification - (list 17 - (format "GNUS: %s%s %s" - gnus-newsgroup-name - (if gnus-current-article - (format "/%d" gnus-current-article) "") - ;; Basic ideas by tale@pawl.rpi.edu. - (cond ((and (zerop unmarked) - (zerop unselected)) - "") - ((zerop unselected) - (format "{%d more}" unmarked)) - (t - (format "{%d(+%d) more}" unmarked unselected))) - )))) - (set-buffer-modified-p t)) - -;; GNUS Summary mode command. - -(defun gnus-summary-search-group (&optional backward) - "Search for next unread newsgroup. -If optional argument BACKWARD is non-nil, search backward instead." - (save-excursion - (set-buffer gnus-group-buffer) - (save-excursion - ;; We don't want to alter current point of Group mode buffer. - (if (gnus-group-search-forward backward nil) - (gnus-group-group-name)) - ))) - -(defun gnus-summary-search-subject (backward unread subject) - "Search for article forward. -If 1st argument BACKWARD is non-nil, search backward. -If 2nd argument UNREAD is non-nil, only unread article is selected. -If 3rd argument SUBJECT is non-nil, the article which has -the same subject will be searched for." - (let ((func - (if backward - (function re-search-backward) (function re-search-forward))) - (article nil) - ;; We have to take care of hidden lines. - (regexp - (format "^%s[ \t]+\\([0-9]+\\):.\\[[^]\r\n]*\\][ \t]+%s" - ;;(if unread " " ".") - (cond ((eq unread t) " ") (unread "[- ]") (t ".")) - (if subject - (concat "\\([Rr][Ee]:[ \t]+\\)*" - (regexp-quote (gnus-simplify-subject subject)) - ;; Ignore words in parentheses. - "\\([ \t]*([^\r\n]*)\\)*[ \t]*\\(\r\\|$\\)") - "") - ))) - (if backward - (beginning-of-line) - (end-of-line)) - (if (funcall func regexp nil t) - (setq article - (string-to-int - (buffer-substring (match-beginning 1) (match-end 1))))) - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - ;; This is the result. - article - )) - -(defun gnus-summary-search-forward (&optional unread subject) - "Search for article forward. -If 1st optional argument UNREAD is non-nil, only unread article is selected. -If 2nd optional argument SUBJECT is non-nil, the article which has -the same subject will be searched for." - (gnus-summary-search-subject nil unread subject)) - -(defun gnus-summary-search-backward (&optional unread subject) - "Search for article backward. -If 1st optional argument UNREAD is non-nil, only unread article is selected. -If 2nd optional argument SUBJECT is non-nil, the article which has -the same subject will be searched for." - (gnus-summary-search-subject t unread subject)) - -(defun gnus-summary-article-number () - "Return the Article number around point. -If none, return current article number." - (save-excursion - (beginning-of-line) - (if (looking-at ".[ \t]+\\([0-9]+\\):") - (string-to-int - (buffer-substring (match-beginning 1) (match-end 1))) - ;; If search fail, return current article number. - gnus-current-article - ))) - -(defun gnus-summary-subject-string () - "Return current subject string or nil if nothing." - (save-excursion - ;; It is possible to implement this function using - ;; `gnus-summary-article-number' and `gnus-newsgroup-headers'. - (beginning-of-line) - ;; We have to take care of hidden lines. - (if (looking-at ".[ \t]+[0-9]+:.\\[[^]\r\n]*\\][ \t]+\\([^\r\n]*\\)[\r\n]") - (buffer-substring (match-beginning 1) (match-end 1))) - )) - -(defun gnus-summary-goto-subject (article) - "Move point to ARTICLE's subject." - (interactive - (list - (string-to-int - (completing-read "Article number: " - (mapcar - (function - (lambda (headers) - (list - (int-to-string (nntp-header-number headers))))) - gnus-newsgroup-headers) - nil 'require-match)))) - (let ((current (point))) - (goto-char (point-min)) - (or (and article (re-search-forward (format "^.[ \t]+%d:" article) nil t)) - (progn (goto-char current) nil)) - )) - -(defun gnus-summary-recenter () - "Center point in Summary window." - ;; Scroll window so as to cursor comes center of Summary window - ;; only when article is displayed. - ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). - ;; Recenter only when requested. - ;; Subbested by popovich@park.cs.columbia.edu - (and gnus-auto-center-summary - (get-buffer-window gnus-article-buffer) - (< (/ (- (window-height) 1) 2) - (count-lines (point) (point-max))) - (recenter (/ (- (window-height) 2) 2)))) - -;; Walking around Group mode buffer. - -(defun gnus-summary-jump-to-group (newsgroup) - "Move point to NEWSGROUP in Group mode buffer." - ;; Keep update point of Group mode buffer if visible. - (if (eq (current-buffer) - (get-buffer gnus-group-buffer)) - (save-window-excursion - ;; Take care of tree window mode. - (if (get-buffer-window gnus-group-buffer) - (pop-to-buffer gnus-group-buffer)) - (gnus-group-jump-to-group newsgroup)) - (save-excursion - ;; Take care of tree window mode. - (if (get-buffer-window gnus-group-buffer) - (pop-to-buffer gnus-group-buffer) - (set-buffer gnus-group-buffer)) - (gnus-group-jump-to-group newsgroup)))) - -(defun gnus-summary-next-group (no-article) - "Exit current newsgroup and then select next unread newsgroup. -If prefix argument NO-ARTICLE is non-nil, no article is selected initially." - (interactive "P") - ;; Make sure Group mode buffer point is on current newsgroup. - (gnus-summary-jump-to-group gnus-newsgroup-name) - (let ((group (gnus-summary-search-group))) - (if (null group) - (progn - (message "Exiting %s..." gnus-newsgroup-name) - (gnus-summary-exit) - (message "")) - (message "Selecting %s..." group) - (gnus-summary-exit t) ;Exit Summary mode temporary. - ;; We are now in Group mode buffer. - ;; Make sure Group mode buffer point is on GROUP. - (gnus-summary-jump-to-group group) - (gnus-summary-read-group group nil no-article) - (or (eq (current-buffer) - (get-buffer gnus-summary-buffer)) - (eq gnus-auto-select-next t) - ;; Expected newsgroup has nothing to read since the articles - ;; are marked as read by cross-referencing. So, try next - ;; newsgroup. (Make sure we are in Group mode buffer now.) - (and (eq (current-buffer) - (get-buffer gnus-group-buffer)) - (gnus-group-group-name) - (gnus-summary-read-group - (gnus-group-group-name) nil no-article)) - ) - ))) - -(defun gnus-summary-prev-group (no-article) - "Exit current newsgroup and then select previous unread newsgroup. -If prefix argument NO-ARTICLE is non-nil, no article is selected initially." - (interactive "P") - ;; Make sure Group mode buffer point is on current newsgroup. - (gnus-summary-jump-to-group gnus-newsgroup-name) - (let ((group (gnus-summary-search-group t))) - (if (null group) - (progn - (message "Exiting %s..." gnus-newsgroup-name) - (gnus-summary-exit) - (message "")) - (message "Selecting %s..." group) - (gnus-summary-exit t) ;Exit Summary mode temporary. - ;; We are now in Group mode buffer. - ;; We have to adjust point of Group mode buffer because current - ;; point is moved to next unread newsgroup by exiting. - (gnus-summary-jump-to-group group) - (gnus-summary-read-group group nil no-article) - (or (eq (current-buffer) - (get-buffer gnus-summary-buffer)) - (eq gnus-auto-select-next t) - ;; Expected newsgroup has nothing to read since the articles - ;; are marked as read by cross-referencing. So, try next - ;; newsgroup. (Make sure we are in Group mode buffer now.) - (and (eq (current-buffer) - (get-buffer gnus-group-buffer)) - (gnus-summary-search-group t) - (gnus-summary-read-group - (gnus-summary-search-group t) nil no-article)) - ) - ))) - -;; Walking around summary lines. - -(defun gnus-summary-next-subject (n &optional unread) - "Go to Nth following summary line. -If optional argument UNREAD is non-nil, only unread article is selected." - (interactive "p") - (while (and (> n 1) - (gnus-summary-search-forward unread)) - (setq n (1- n))) - (cond ((gnus-summary-search-forward unread) - (gnus-summary-recenter)) - (unread - (message "No more unread articles")) - (t - (message "No more articles")) - )) - -(defun gnus-summary-next-unread-subject (n) - "Go to Nth following unread summary line." - (interactive "p") - (gnus-summary-next-subject n t)) - -(defun gnus-summary-prev-subject (n &optional unread) - "Go to Nth previous summary line. -If optional argument UNREAD is non-nil, only unread article is selected." - (interactive "p") - (while (and (> n 1) - (gnus-summary-search-backward unread)) - (setq n (1- n))) - (cond ((gnus-summary-search-backward unread) - (gnus-summary-recenter)) - (unread - (message "No more unread articles")) - (t - (message "No more articles")) - )) - -(defun gnus-summary-prev-unread-subject (n) - "Go to Nth previous unread summary line." - (interactive "p") - (gnus-summary-prev-subject n t)) - -;; Walking around summary lines with displaying articles. - -(defun gnus-summary-expand-window () - "Expand Summary window to show headers full window." - (interactive) - (gnus-configure-windows 'summary) - (pop-to-buffer gnus-summary-buffer)) - -(defun gnus-summary-display-article (article &optional all-header) - "Display ARTICLE in Article buffer." - (if (null article) - nil - (gnus-configure-windows 'article) - (pop-to-buffer gnus-summary-buffer) - (gnus-article-prepare article all-header) - (gnus-summary-recenter) - (gnus-summary-set-mode-line) - (run-hooks 'gnus-select-article-hook) - ;; Successfully display article. - t - )) - -(defun gnus-summary-select-article (&optional all-headers force) - "Select the current article. -Optional first argument ALL-HEADERS is non-nil, show all header fields. -Optional second argument FORCE is nil, the article is only selected -again when current header does not match with ALL-HEADERS option." - (let ((article (gnus-summary-article-number)) - (all-headers (not (not all-headers)))) ;Must be T or NIL. - (if (or (null gnus-current-article) - (/= article gnus-current-article) - (and force (not (eq all-headers gnus-have-all-headers)))) - ;; The selected one is different from that of the current article. - (gnus-summary-display-article article all-headers) - (gnus-configure-windows 'article) - (pop-to-buffer gnus-summary-buffer)) - )) - -(defun gnus-summary-set-current-mark (&optional current-mark) - "Put `+' at the current article. -Optional argument specifies CURRENT-MARK instead of `+'." - (save-excursion - (set-buffer gnus-summary-buffer) - (let ((buffer-read-only nil)) - (goto-char (point-min)) - ;; First of all clear mark at last article. - (if (re-search-forward "^.[ \t]+[0-9]+:[^ \t]" nil t) - (progn - (delete-char -1) - (insert " ") - (goto-char (point-min)))) - (if (re-search-forward (format "^.[ \t]+%d:" gnus-current-article) nil t) - (progn - (delete-char 1) - (insert (or current-mark "+")))) - ))) - -;;(defun gnus-summary-next-article (unread &optional subject) -;; "Select article after current one. -;;If argument UNREAD is non-nil, only unread article is selected." -;; (interactive "P") -;; (cond ((gnus-summary-display-article -;; (gnus-summary-search-forward unread subject))) -;; (unread -;; (message "No more unread articles")) -;; (t -;; (message "No more articles")) -;; )) - -(defun gnus-summary-next-article (unread &optional subject) - "Select article after current one. -If argument UNREAD is non-nil, only unread article is selected." - (interactive "P") - (let ((header nil)) - (cond ((gnus-summary-display-article - (gnus-summary-search-forward unread subject))) - ((and subject - gnus-auto-select-same - (gnus-set-difference gnus-newsgroup-unreads - gnus-newsgroup-marked) - (memq this-command - '(gnus-summary-next-unread-article - gnus-summary-next-page - gnus-summary-kill-same-subject-and-select - ;;gnus-summary-next-article - ;;gnus-summary-next-same-subject - ;;gnus-summary-next-unread-same-subject - ))) - ;; Wrap article pointer if there are unread articles. - ;; Hook function, such as gnus-summary-rmail-digest, may - ;; change current buffer, so need check. - (let ((buffer (current-buffer)) - (last-point (point))) - ;; No more articles with same subject, so jump to the first - ;; unread article. - (gnus-summary-first-unread-article) - ;;(and (eq buffer (current-buffer)) - ;; (= (point) last-point) - ;; ;; Ignore given SUBJECT, and try again. - ;; (gnus-summary-next-article unread nil)) - (and (eq buffer (current-buffer)) - (< (point) last-point) - (message "Wrapped")) - )) - ((and gnus-auto-extend-newsgroup - (not unread) ;Not unread only - (not subject) ;Only if subject is not specified. - (setq header (gnus-more-header-forward))) - ;; Extend to next article if possible. - ;; Basic ideas by himacdonald@watdragon.waterloo.edu - (gnus-extend-newsgroup header nil) - ;; Threads feature must be turned off. - (let ((buffer-read-only nil)) - (goto-char (point-max)) - (gnus-summary-prepare-threads (list header) 0)) - (gnus-summary-goto-article gnus-newsgroup-end)) - (t - ;; Select next newsgroup automatically if requested. - (let ((cmd (aref (this-command-keys) 0)) - (group (gnus-summary-search-group)) - (auto-select - (and gnus-auto-select-next - ;;(null (gnus-set-difference gnus-newsgroup-unreads - ;; gnus-newsgroup-marked)) - (memq this-command - '(gnus-summary-next-unread-article - gnus-summary-next-article - gnus-summary-next-page - gnus-summary-next-same-subject - gnus-summary-next-unread-same-subject - gnus-summary-kill-same-subject - gnus-summary-kill-same-subject-and-select - )) - ;; Ignore characters typed ahead. - (not (input-pending-p)) - ))) - ;; Keep just the event type of CMD. - (if (listp cmd) - (setq cmd (car cmd))) - (message "No more%s articles%s" - (if unread " unread" "") - (if (and auto-select - (not (eq gnus-auto-select-next 'quietly))) - (if group - (format " (Type %s for %s [%d])" - (single-key-description cmd) - group - (nth 1 (gnus-gethash group - gnus-unread-hashtb))) - (format " (Type %s to exit %s)" - (single-key-description cmd) - gnus-newsgroup-name)) - "")) - ;; Select next unread newsgroup automagically. - (cond ((and auto-select - (eq gnus-auto-select-next 'quietly)) - ;; Select quietly. - (gnus-summary-next-group nil)) - (auto-select - ;; Confirm auto selection. - (let* ((event (read-event)) - (type - (if (listp event) - (car event) - event))) - (if (and (eq event type) (eq event cmd)) - (gnus-summary-next-group nil) - (setq unread-command-events (list event))))) - ) - )) - ))) - -(defun gnus-summary-next-unread-article () - "Select unread article after current one." - (interactive) - (gnus-summary-next-article t (and gnus-auto-select-same - (gnus-summary-subject-string)))) - -(defun gnus-summary-prev-article (unread &optional subject) - "Select article before current one. -If argument UNREAD is non-nil, only unread article is selected." - (interactive "P") - (let ((header nil)) - (cond ((gnus-summary-display-article - (gnus-summary-search-backward unread subject))) - ((and subject - gnus-auto-select-same - (gnus-set-difference gnus-newsgroup-unreads - gnus-newsgroup-marked) - (memq this-command - '(gnus-summary-prev-unread-article - ;;gnus-summary-prev-page - ;;gnus-summary-prev-article - ;;gnus-summary-prev-same-subject - ;;gnus-summary-prev-unread-same-subject - ))) - ;; Ignore given SUBJECT, and try again. - (gnus-summary-prev-article unread nil)) - (unread - (message "No more unread articles")) - ((and gnus-auto-extend-newsgroup - (not subject) ;Only if subject is not specified. - (setq header (gnus-more-header-backward))) - ;; Extend to previous article if possible. - ;; Basic ideas by himacdonald@watdragon.waterloo.edu - (gnus-extend-newsgroup header t) - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (gnus-summary-prepare-threads (list header) 0)) - (gnus-summary-goto-article gnus-newsgroup-begin)) - (t - (message "No more articles")) - ))) - -(defun gnus-summary-prev-unread-article () - "Select unread article before current one." - (interactive) - (gnus-summary-prev-article t (and gnus-auto-select-same - (gnus-summary-subject-string)))) - -(defun gnus-summary-next-page (lines) - "Show next page of selected article. -If end of article, select next article. -Argument LINES specifies lines to be scrolled up." - (interactive "P") - (let ((article (gnus-summary-article-number)) - (endp nil)) - (if (or (null gnus-current-article) - (/= article gnus-current-article)) - ;; Selected subject is different from current article's. - (gnus-summary-display-article article) - (gnus-configure-windows 'article) - (pop-to-buffer gnus-summary-buffer) - (gnus-eval-in-buffer-window gnus-article-buffer - (setq endp (gnus-article-next-page lines))) - (cond ((and endp lines) - (message "End of message")) - ((and endp (null lines)) - (gnus-summary-next-unread-article))) - ))) - -(defun gnus-summary-prev-page (lines) - "Show previous page of selected article. -Argument LINES specifies lines to be scrolled down." - (interactive "P") - (let ((article (gnus-summary-article-number))) - (if (or (null gnus-current-article) - (/= article gnus-current-article)) - ;; Selected subject is different from current article's. - (gnus-summary-display-article article) - (gnus-configure-windows 'article) - (pop-to-buffer gnus-summary-buffer) - (gnus-eval-in-buffer-window gnus-article-buffer - (gnus-article-prev-page lines)) - ))) - -(defun gnus-summary-scroll-up (lines) - "Scroll up (or down) one line current article. -Argument LINES specifies lines to be scrolled up (or down if negative)." - (interactive "p") - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (cond ((> lines 0) - (if (gnus-article-next-page lines) - (message "End of message"))) - ((< lines 0) - (gnus-article-prev-page (- 0 lines)))) - )) - -(defun gnus-summary-next-same-subject () - "Select next article which has the same subject as current one." - (interactive) - (gnus-summary-next-article nil (gnus-summary-subject-string))) - -(defun gnus-summary-prev-same-subject () - "Select previous article which has the same subject as current one." - (interactive) - (gnus-summary-prev-article nil (gnus-summary-subject-string))) - -(defun gnus-summary-next-unread-same-subject () - "Select next unread article which has the same subject as current one." - (interactive) - (gnus-summary-next-article t (gnus-summary-subject-string))) - -(defun gnus-summary-prev-unread-same-subject () - "Select previous unread article which has the same subject as current one." - (interactive) - (gnus-summary-prev-article t (gnus-summary-subject-string))) - -(defun gnus-summary-refer-parent-article (child) - "Refer parent article of current article. -If a prefix argument CHILD is non-nil, go back to the child article -using internally maintained articles history. -NOTE: This command may not work with `nnspool.el'." - (interactive "P") - (gnus-summary-select-article t t) ;Request all headers. - (let ((referenced-id nil)) ;Message-id of parent or child article. - (if child - ;; Go back to child article using history. - (gnus-summary-refer-article nil) - (gnus-eval-in-buffer-window gnus-article-buffer - ;; Look for parent Message-ID. - ;; We cannot use gnus-current-headers to get references - ;; because we may be looking at parent or referred article. - (let ((references (gnus-fetch-field "References"))) - ;; Get the last message-id in the references. - (and references - (string-match "\\(<[^<>]+>\\)[^>]*\\'" references) - (setq referenced-id - (substring references - (match-beginning 1) (match-end 1)))) - )) - (if (stringp referenced-id) - (gnus-summary-refer-article referenced-id) - (error "No more parents")) - ))) - -(defun gnus-summary-refer-article (message-id) - "Refer article specified by MESSAGE-ID. -If the MESSAGE-ID is nil or an empty string, Message-ID is poped from -internally maintained articles history. -NOTE: This command may not work with `nnspool.el' nor `mhspool.el'." - (interactive "sMessage-ID: ") - ;; Make sure that this command depends on the fact that article - ;; related information is not updated when an article is retrieved - ;; by Message-ID. - (gnus-summary-select-article t t) ;Request all headers. - (if (and (stringp message-id) - (> (length message-id) 0)) - (gnus-eval-in-buffer-window gnus-article-buffer - ;; Construct the correct Message-ID if necessary. - ;; Suggested by tale@pawl.rpi.edu. - (or (string-match "^<" message-id) - (setq message-id (concat "<" message-id))) - (or (string-match ">$" message-id) - (setq message-id (concat message-id ">"))) - ;; Push current message-id on history. - ;; We cannot use gnus-current-headers to get current - ;; message-id because we may be looking at parent or referred - ;; article. - (let ((current (gnus-fetch-field "Message-ID"))) - (or (equal current message-id) ;Nothing to do. - (equal current (car gnus-current-history)) - (setq gnus-current-history - (cons current gnus-current-history))) - )) - ;; Pop message-id from history. - (setq message-id (car gnus-current-history)) - (setq gnus-current-history (cdr gnus-current-history))) - (if (stringp message-id) - ;; Retrieve article by message-id. This may not work with - ;; nnspool nor mhspool. - (gnus-article-prepare message-id t) - (error "No such references")) - ) - -(defun gnus-summary-next-digest (n) - "Move to head of Nth next digested message." - (interactive "p") - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (gnus-article-next-digest (or n 1)) - )) - -(defun gnus-summary-prev-digest (n) - "Move to head of Nth previous digested message." - (interactive "p") - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (gnus-article-prev-digest (or n 1)))) - -(defun gnus-summary-first-unread-article () - "Select first unread article. Return non-nil if successfully selected." - (interactive) - (let ((begin (point))) - (goto-char (point-min)) - (if (re-search-forward "^ [ \t]+[0-9]+:" nil t) - (gnus-summary-display-article (gnus-summary-article-number)) - ;; If there is no unread articles, stay there. - (goto-char begin) - ;;(gnus-summary-display-article (gnus-summary-article-number)) - (message "No more unread articles") - nil - ) - )) - -(defun gnus-summary-isearch-article () - "Do incremental search forward on current article." - (interactive) - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (isearch-forward))) - -(defun gnus-summary-search-article-forward (regexp) - "Search for an article containing REGEXP forward. -`gnus-select-article-hook' is not called for articles examined -by searching search." - (interactive - (list (read-string - (concat "Search forward (regexp): " - (if gnus-last-search-regexp - (concat "(default " gnus-last-search-regexp ") ")))))) - (if (string-equal regexp "") - (setq regexp (or gnus-last-search-regexp "")) - (setq gnus-last-search-regexp regexp)) - (if (gnus-summary-search-article regexp nil) - (gnus-eval-in-buffer-window gnus-article-buffer - (recenter 0) - ;;(sit-for 1) - ) - (error "Search failed: \"%s\"" regexp) - )) - -(defun gnus-summary-search-article-backward (regexp) - "Search for an article containing REGEXP backward. -`gnus-select-article-hook' is not called for articles examined -by searching search." - (interactive - (list (read-string - (concat "Search backward (regexp): " - (if gnus-last-search-regexp - (concat "(default " gnus-last-search-regexp ") ")))))) - (if (string-equal regexp "") - (setq regexp (or gnus-last-search-regexp "")) - (setq gnus-last-search-regexp regexp)) - (if (gnus-summary-search-article regexp t) - (gnus-eval-in-buffer-window gnus-article-buffer - (recenter 0) - ;;(sit-for 1) - ) - (error "Search failed: \"%s\"" regexp) - )) - -(defun gnus-summary-search-article (regexp &optional backward) - "Search for an article containing REGEXP. -Optional argument BACKWARD means do search for backward. -`gnus-select-article-hook' is not called for articles examined -by searching search." - (let ((gnus-select-article-hook nil) ;Disable hook. - (gnus-mark-article-hook nil) ;Inhibit marking as read. - (re-search - (if backward - (function re-search-backward) (function re-search-forward))) - (found nil) - (last nil)) - ;; Hidden thread subtrees must be searched for ,too. - (gnus-summary-show-all-threads) - ;; First of all, search current article. - ;; We don't want to read article again from NNTP server nor reset - ;; current point. - (gnus-summary-select-article) - (message "Searching article: %d..." gnus-current-article) - (setq last gnus-current-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction - (widen) - ;; Begin search from current point. - (setq found (funcall re-search regexp nil t)))) - ;; Then search next articles. - (while (and (not found) - (gnus-summary-display-article - (gnus-summary-search-subject backward nil nil))) - (message "Searching article: %d..." gnus-current-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction - (widen) - (goto-char (if backward (point-max) (point-min))) - (setq found (funcall re-search regexp nil t))) - )) - (message "") - ;; Adjust article pointer. - (or (eq last gnus-current-article) - (setq gnus-last-article last)) - ;; Return T if found such article. - found - )) - -(defun gnus-summary-execute-command (field regexp command &optional backward) - "If FIELD of article header matches REGEXP, execute a COMMAND string. -If FIELD is an empty string (or nil), entire article body is searched for. -If optional (prefix) argument BACKWARD is non-nil, do backward instead." - (interactive - (list (let ((completion-ignore-case t)) - (completing-read "Field name: " - '(("Number")("Subject")("From") - ("Lines")("Date")("Id") - ("Xref")("References")) - nil 'require-match)) - (read-string "Regexp: ") - (read-key-sequence "Command: ") - current-prefix-arg)) - ;; Hidden thread subtrees must be searched for ,too. - (gnus-summary-show-all-threads) - ;; We don't want to change current point nor window configuration. - (save-excursion - (save-window-excursion - (message "Executing %s..." (key-description command)) - ;; We'd like to execute COMMAND interactively so as to give arguments. - (gnus-execute field regexp - (` (lambda () - (call-interactively '(, (key-binding command))))) - backward) - (message "Executing %s...done" (key-description command))))) - -(defun gnus-summary-beginning-of-article () - "Go to beginning of article body." - (interactive) - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (widen) - (beginning-of-buffer) - (if gnus-break-pages - (gnus-narrow-to-page)) - )) - -(defun gnus-summary-end-of-article () - "Go to end of article body." - (interactive) - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (widen) - (end-of-buffer) - (if gnus-break-pages - (gnus-narrow-to-page)) - )) - -(defun gnus-summary-goto-article (article &optional all-headers) - "Read article number ARTICLE if it exists. -Optional argument ALL-HEADERS means show the full header." - (interactive - (list - (string-to-int - (completing-read "Article number: " - (mapcar - (function - (lambda (headers) - (list - (int-to-string (nntp-header-number headers))))) - gnus-newsgroup-headers) - nil 'require-match)))) - (if (gnus-summary-goto-subject article) - (gnus-summary-display-article article all-headers))) - -(defun gnus-summary-goto-last-article () - "Go to last subject line." - (interactive) - (if gnus-last-article - (gnus-summary-goto-article gnus-last-article))) - -(defun gnus-summary-show-article () - "Force to show current article." - (interactive) - ;; The following is a trick to force to read the current article again. - (setq gnus-have-all-headers (not gnus-have-all-headers)) - (gnus-summary-select-article (not gnus-have-all-headers) t)) - -(defun gnus-summary-toggle-header (arg) - "Show original header if pruned header currently shown, or vice versa. -With arg, show original header iff arg is positive." - (interactive "P") - ;; Variable gnus-show-all-headers must be NIL to toggle really. - (let ((gnus-show-all-headers nil) - (all-headers - (if (null arg) (not gnus-have-all-headers) - (> (prefix-numeric-value arg) 0)))) - (gnus-summary-select-article all-headers t))) - -(defun gnus-summary-show-all-headers () - "Show original article header." - (interactive) - (gnus-summary-select-article t t)) - -(defun gnus-summary-toggle-mime (arg) - "Toggle MIME processing. -With arg, turn MIME processing on iff arg is positive." - (interactive "P") - (setq gnus-show-mime - (if (null arg) (not gnus-show-mime) - (> (prefix-numeric-value arg) 0))) - ;; The following is a trick to force to read the current article again. - (setq gnus-have-all-headers (not gnus-have-all-headers)) - (gnus-summary-select-article (not gnus-have-all-headers) t)) - -(defun gnus-summary-stop-page-breaking () - "Stop page breaking by linefeed temporary (widen article buffer)." - (interactive) - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (widen) - )) - -(defun gnus-summary-kill-same-subject-and-select (unmark) - "Mark articles which has the same subject as read, and then select next. -If argument UNMARK is positive, remove any kinds of marks. -If argument UNMARK is negative, mark articles as unread instead." - (interactive "P") - (if unmark - (setq unmark (prefix-numeric-value unmark))) - (let ((count - (gnus-summary-mark-same-subject - (gnus-summary-subject-string) unmark))) - ;; Select next unread article. If auto-select-same mode, should - ;; select the first unread article. - (gnus-summary-next-article t (and gnus-auto-select-same - (gnus-summary-subject-string))) - (message "%d articles are marked as %s" - count (if unmark "unread" "read")) - )) - -(defun gnus-summary-kill-same-subject (unmark) - "Mark articles which has the same subject as read. -If argument UNMARK is positive, remove any kinds of marks. -If argument UNMARK is negative, mark articles as unread instead." - (interactive "P") - (if unmark - (setq unmark (prefix-numeric-value unmark))) - (let ((count - (gnus-summary-mark-same-subject - (gnus-summary-subject-string) unmark))) - ;; If marked as read, go to next unread subject. - (if (null unmark) - ;; Go to next unread subject. - (gnus-summary-next-subject 1 t)) - (message "%d articles are marked as %s" - count (if unmark "unread" "read")) - )) - -(defun gnus-summary-mark-same-subject (subject &optional unmark) - "Mark articles with same SUBJECT as read, and return marked number. -If optional argument UNMARK is positive, remove any kinds of marks. -If optional argument UNMARK is negative, mark articles as unread instead." - (let ((count 1)) - (save-excursion - (cond ((null unmark) - (gnus-summary-mark-as-read nil "K")) - ((> unmark 0) - (gnus-summary-mark-as-unread nil t)) - (t - (gnus-summary-mark-as-unread))) - (while (and subject - (gnus-summary-search-forward nil subject)) - (cond ((null unmark) - (gnus-summary-mark-as-read nil "K")) - ((> unmark 0) - (gnus-summary-mark-as-unread nil t)) - (t - (gnus-summary-mark-as-unread))) - (setq count (1+ count)) - )) - ;; Hide killed thread subtrees. Does not work properly always. - ;;(and (null unmark) - ;; gnus-thread-hide-killed - ;; (gnus-summary-hide-thread)) - ;; Return number of articles marked as read. - count - )) - -(defun gnus-summary-mark-as-unread-forward (count) - "Mark current article as unread, and then go forward. -Argument COUNT specifies number of articles marked as unread." - (interactive "p") - (while (> count 0) - (gnus-summary-mark-as-unread nil nil) - (gnus-summary-next-subject 1 nil) - (setq count (1- count)))) - -(defun gnus-summary-mark-as-unread-backward (count) - "Mark current article as unread, and then go backward. -Argument COUNT specifies number of articles marked as unread." - (interactive "p") - (while (> count 0) - (gnus-summary-mark-as-unread nil nil) - (gnus-summary-prev-subject 1 nil) - (setq count (1- count)))) - -(defun gnus-summary-mark-as-unread (&optional article clear-mark) - "Mark current article as unread. -Optional 1st argument ARTICLE specifies article number to be marked as unread. -Optional 2nd argument CLEAR-MARK remove any kinds of mark." - (save-excursion - (set-buffer gnus-summary-buffer) - ;; First of all, show hidden thread subtrees. - (gnus-summary-show-thread) - (let* ((buffer-read-only nil) - (current (gnus-summary-article-number)) - (article (or article current))) - (gnus-mark-article-as-unread article clear-mark) - (if (or (eq article current) - (gnus-summary-goto-subject article)) - (progn - (beginning-of-line) - (delete-char 1) - (insert (if clear-mark " " "-")))) - ))) - -(defun gnus-summary-mark-as-read-forward (count) - "Mark current article as read, and then go forward. -Argument COUNT specifies number of articles marked as read." - (interactive "p") - (while (> count 0) - (gnus-summary-mark-as-read) - (gnus-summary-next-subject 1 'unread-only) - (setq count (1- count)))) - -(defun gnus-summary-mark-as-read-backward (count) - "Mark current article as read, and then go backward. -Argument COUNT specifies number of articles marked as read." - (interactive "p") - (while (> count 0) - (gnus-summary-mark-as-read) - (gnus-summary-prev-subject 1 'unread-only) - (setq count (1- count)))) - -(defun gnus-summary-mark-as-read (&optional article mark) - "Mark current article as read. -Optional 1st argument ARTICLE specifies article number to be marked as read. -Optional 2nd argument MARK specifies a string inserted at beginning of line. -Any kind of string (length 1) except for a space and `-' is ok." - (save-excursion - (set-buffer gnus-summary-buffer) - ;; First of all, show hidden thread subtrees. - (gnus-summary-show-thread) - (let* ((buffer-read-only nil) - (mark (or mark "D")) ;Default mark is `D'. - (current (gnus-summary-article-number)) - (article (or article current))) - (gnus-mark-article-as-read article) - (if (or (eq article current) - (gnus-summary-goto-subject article)) - (progn - (beginning-of-line) - (delete-char 1) - (insert mark))) - ))) - -(defun gnus-summary-clear-mark-forward (count) - "Remove current article's mark, and go forward. -Argument COUNT specifies number of articles unmarked." - (interactive "p") - (while (> count 0) - (gnus-summary-mark-as-unread nil t) - (gnus-summary-next-subject 1 nil) - (setq count (1- count)))) - -(defun gnus-summary-clear-mark-backward (count) - "Remove current article's mark, and go backward. -Argument COUNT specifies number of articles unmarked." - (interactive "p") - (while (> count 0) - (gnus-summary-mark-as-unread nil t) - (gnus-summary-prev-subject 1 nil) - (setq count (1- count)))) - -(defun gnus-summary-delete-marked-as-read () - "Delete summary lines for articles that are marked as read." - (interactive) - (if gnus-newsgroup-unreads - (let ((buffer-read-only nil)) - (save-excursion - (goto-char (point-min)) - (delete-non-matching-lines "^[- ]")) - ;; Adjust point. - (if (eobp) - (gnus-summary-prev-subject 1) - (beginning-of-line) - (search-forward ":" nil t))) - ;; It is not so good idea to make the buffer empty. - (message "All articles are marked as read") - )) - -(defun gnus-summary-delete-marked-with (marks) - "Delete lines which are marked with MARKS (e.g. \"DK\")." - (interactive "sMarks: ") - (let ((buffer-read-only nil)) - (save-excursion - (goto-char (point-min)) - (delete-matching-lines (concat "^[" marks "]"))) - ;; Adjust point. - (or (zerop (buffer-size)) - (if (eobp) - (gnus-summary-prev-subject 1) - (beginning-of-line) - (search-forward ":" nil t))) - )) - -;; Thread-based commands. - -(defun gnus-summary-toggle-threads (arg) - "Toggle showing conversation threads. -With arg, turn showing conversation threads on iff arg is positive." - (interactive "P") - (let ((current (gnus-summary-article-number))) - (setq gnus-show-threads - (if (null arg) (not gnus-show-threads) - (> (prefix-numeric-value arg) 0))) - (gnus-summary-prepare) - (gnus-summary-goto-subject current) - )) - -(defun gnus-summary-show-all-threads () - "Show all thread subtrees." - (interactive) - (if gnus-show-threads - (save-excursion - (let ((buffer-read-only nil)) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - )))) - -(defun gnus-summary-show-thread () - "Show thread subtrees." - (interactive) - (if gnus-show-threads - (save-excursion - (let ((buffer-read-only nil)) - (subst-char-in-region (progn - (beginning-of-line) (point)) - (progn - (end-of-line) (point)) - ?\^M ?\n t) - )))) - -(defun gnus-summary-hide-all-threads () - "Hide all thread subtrees." - (interactive) - (if gnus-show-threads - (save-excursion - ;; Adjust cursor point. - (goto-char (point-min)) - (search-forward ":" nil t) - (let ((level (current-column))) - (gnus-summary-hide-thread) - (while (gnus-summary-search-forward) - (and (>= level (current-column)) - (gnus-summary-hide-thread))) - )))) - -(defun gnus-summary-hide-thread () - "Hide thread subtrees." - (interactive) - (if gnus-show-threads - (save-excursion - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - (let ((buffer-read-only nil) - (init (point)) - (last (point)) - (level (current-column))) - (while (and (gnus-summary-search-forward) - (< level (current-column))) - ;; Interested in lower levels. - (if (< level (current-column)) - (progn - (setq last (point)) - )) - ) - (subst-char-in-region init last ?\n ?\^M t) - )))) - -(defun gnus-summary-next-thread (n) - "Go to the same level next thread. -Argument N specifies the number of threads." - (interactive "p") - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - (let ((init (point)) - (last (point)) - (level (current-column))) - (while (and (> n 0) - (gnus-summary-search-forward) - (<= level (current-column))) - ;; We have to skip lower levels. - (if (= level (current-column)) - (progn - (setq last (point)) - (setq n (1- n)) - )) - ) - ;; Return non-nil if successfully move to the next. - (prog1 (not (= init last)) - (goto-char last)) - )) - -(defun gnus-summary-prev-thread (n) - "Go to the same level previous thread. -Argument N specifies the number of threads." - (interactive "p") - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - (let ((init (point)) - (last (point)) - (level (current-column))) - (while (and (> n 0) - (gnus-summary-search-backward) - (<= level (current-column))) - ;; We have to skip lower levels. - (if (= level (current-column)) - (progn - (setq last (point)) - (setq n (1- n)) - )) - ) - ;; Return non-nil if successfully move to the previous. - (prog1 (not (= init last)) - (goto-char last)) - )) - -(defun gnus-summary-down-thread (d) - "Go downward current thread. -Argument D specifies the depth goes down." - (interactive "p") - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - (let ((last (point)) - (level (current-column))) - (while (and (> d 0) - (gnus-summary-search-forward) - (<= level (current-column))) ;<= can be <. Which do you like? - ;; We have to skip the same levels. - (if (< level (current-column)) - (progn - (setq last (point)) - (setq level (current-column)) - (setq d (1- d)) - )) - ) - (goto-char last) - )) - -(defun gnus-summary-up-thread (d) - "Go upward current thread. -Argument D specifies the depth goes up." - (interactive "p") - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - (let ((last (point)) - (level (current-column))) - (while (and (> d 0) - (gnus-summary-search-backward)) - ;; We have to skip the same levels. - (if (> level (current-column)) - (progn - (setq last (point)) - (setq level (current-column)) - (setq d (1- d)) - )) - ) - (goto-char last) - )) - -(defun gnus-summary-kill-thread (unmark) - "Mark articles under current thread as read. -If argument UNMARK is positive, remove any kinds of marks. -If argument UNMARK is negative, mark articles as unread instead." - (interactive "P") - (if unmark - (setq unmark (prefix-numeric-value unmark))) - ;; Adjust cursor point. - (beginning-of-line) - (search-forward ":" nil t) - (save-excursion - (let ((level (current-column))) - ;; Mark current article. - (cond ((null unmark) - (gnus-summary-mark-as-read nil "K")) - ((> unmark 0) - (gnus-summary-mark-as-unread nil t)) - (t - (gnus-summary-mark-as-unread)) - ) - ;; Mark following articles. - (while (and (gnus-summary-search-forward) - (< level (current-column))) - (cond ((null unmark) - (gnus-summary-mark-as-read nil "K")) - ((> unmark 0) - (gnus-summary-mark-as-unread nil t)) - (t - (gnus-summary-mark-as-unread)) - )) - )) - ;; Hide killed subtrees. - (and (null unmark) - gnus-thread-hide-killed - (gnus-summary-hide-thread)) - ;; If marked as read, go to next unread subject. - (if (null unmark) - ;; Go to next unread subject. - (gnus-summary-next-subject 1 t)) - ) - -(defun gnus-summary-toggle-truncation (arg) - "Toggle truncation of summary lines. -With arg, turn line truncation on iff arg is positive." - (interactive "P") - (setq truncate-lines - (if (null arg) (not truncate-lines) - (> (prefix-numeric-value arg) 0))) - (redraw-display)) - -(defun gnus-summary-sort-by-number (reverse) - "Sort Summary buffer by article number. -Argument REVERSE means reverse order." - (interactive "P") - (gnus-summary-keysort-summary - (function <) - (function - (lambda (a) - (nntp-header-number a))) - reverse - )) - -(defun gnus-summary-sort-by-author (reverse) - "Sort Summary buffer by author name alphabetically. -If case-fold-search is non-nil, case of letters is ignored. -Argument REVERSE means reverse order." - (interactive "P") - (gnus-summary-keysort-summary - (function string-lessp) - (function - (lambda (a) - (if case-fold-search - (downcase (nntp-header-from a)) - (nntp-header-from a)))) - reverse - )) - -(defun gnus-summary-sort-by-subject (reverse) - "Sort Summary buffer by subject alphabetically. `Re:'s are ignored. -If case-fold-search is non-nil, case of letters is ignored. -Argument REVERSE means reverse order." - (interactive "P") - (gnus-summary-keysort-summary - (function string-lessp) - (function - (lambda (a) - (if case-fold-search - (downcase (gnus-simplify-subject (nntp-header-subject a) 're-only)) - (gnus-simplify-subject (nntp-header-subject a) 're-only)))) - reverse - )) - -(defun gnus-summary-sort-by-date (reverse) - "Sort Summary buffer by date. -Argument REVERSE means reverse order." - (interactive "P") - (gnus-summary-keysort-summary - (function string-lessp) - (function - (lambda (a) - (gnus-sortable-date (nntp-header-date a)))) - reverse - )) - -(defun gnus-summary-keysort-summary (predicate key &optional reverse) - "Sort Summary buffer by PREDICATE using a value passed by KEY. -Optional argument REVERSE means reverse order." - (let ((current (gnus-summary-article-number))) - (gnus-keysort-headers predicate key reverse) - (gnus-summary-prepare) - (gnus-summary-goto-subject current) - )) - -(defun gnus-summary-sort-summary (predicate &optional reverse) - "Sort Summary buffer by PREDICATE. -Optional argument REVERSE means reverse order." - (let ((current (gnus-summary-article-number))) - (gnus-sort-headers predicate reverse) - (gnus-summary-prepare) - (gnus-summary-goto-subject current) - )) - -(defun gnus-summary-reselect-current-group (show-all) - "Once exit and then reselect the current newsgroup. -Prefix argument SHOW-ALL means to select all articles." - (interactive "P") - (let ((current-subject (gnus-summary-article-number))) - (gnus-summary-exit t) - ;; We have to adjust the point of Group mode buffer because the - ;; current point was moved to the next unread newsgroup by - ;; exiting. - (gnus-summary-jump-to-group gnus-newsgroup-name) - (gnus-group-read-group show-all t) - (gnus-summary-goto-subject current-subject) - )) - -(defun gnus-summary-caesar-message (rotnum) - "Caesar rotates all letters of current message by 13/47 places. -With prefix arg, specifies the number of places to rotate each letter forward. -Caesar rotates Japanese letters by 47 places in any case." - (interactive "P") - (gnus-summary-select-article) - (gnus-overload-functions) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction - (widen) - ;; We don't want to jump to the beginning of the message. - ;; `save-excursion' does not do its job. - (move-to-window-line 0) - (let ((last (point))) - (news-caesar-buffer-body rotnum) - (goto-char last) - (recenter 0) - )) - )) - -(defun gnus-summary-rmail-digest () - "Run RMAIL on current digest article. -`gnus-select-digest-hook' will be called with no arguments, if that -value is non-nil. It is possible to modify the article so that Rmail -can work with it. -`gnus-rmail-digest-hook' will be called with no arguments, if that value -is non-nil. The hook is intended to customize Rmail mode." - (interactive) - (gnus-summary-select-article) - (require 'rmail) - (let ((artbuf gnus-article-buffer) - (digbuf (get-buffer-create gnus-digest-buffer)) - (mail-header-separator "")) - (set-buffer digbuf) - (buffer-flush-undo (current-buffer)) - (setq buffer-read-only nil) - (erase-buffer) - (insert-buffer-substring artbuf) - (run-hooks 'gnus-select-digest-hook) - (gnus-convert-article-to-rmail) - (goto-char (point-min)) - ;; Rmail initializations. - (rmail-insert-rmail-file-header) - (rmail-mode) - (rmail-set-message-counters) - (rmail-show-message) - (condition-case () - (progn - (undigestify-rmail-message) - (rmail-expunge) ;Delete original message. - ;; File name is meaningless but `save-buffer' requires it. - (setq buffer-file-name "GNUS Digest") - (setq mode-line-buffer-identification - (concat "Digest: " - (nntp-header-subject gnus-current-headers))) - ;; There is no need to write this buffer to a file. - (make-local-variable 'write-file-hooks) - (setq write-file-hooks - (list (function - (lambda () - (set-buffer-modified-p nil) - (message "(No changes need to be saved)") - 'no-need-to-write-this-buffer)))) - ;; Default file name saving digest messages. - (setq rmail-default-rmail-file - (funcall gnus-rmail-save-name - gnus-newsgroup-name - gnus-current-headers - gnus-newsgroup-last-rmail - )) - (setq rmail-default-file - (funcall gnus-mail-save-name - gnus-newsgroup-name - gnus-current-headers - gnus-newsgroup-last-mail - )) - ;; Prevent generating new buffer named ***<N> each time. - (setq rmail-summary-buffer - (get-buffer-create gnus-digest-summary-buffer)) - (run-hooks 'gnus-rmail-digest-hook) - ;; Take all windows safely. - (gnus-configure-windows '(1 0 0)) - (pop-to-buffer gnus-group-buffer) - ;; Use Summary Article windows for Digest summary and - ;; Digest buffers. - (if gnus-digest-show-summary - (let ((gnus-summary-buffer gnus-digest-summary-buffer) - (gnus-article-buffer gnus-digest-buffer)) - (gnus-configure-windows 'article) - (pop-to-buffer gnus-digest-buffer) - (rmail-summary) - (pop-to-buffer gnus-digest-summary-buffer) - (message (substitute-command-keys - "Type \\[rmail-summary-quit] to return to GNUS"))) - (let ((gnus-summary-buffer gnus-digest-buffer)) - (gnus-configure-windows 'summary) - (pop-to-buffer gnus-digest-buffer) - (message (substitute-command-keys - "Type \\[rmail-quit] to return to GNUS"))) - ) - ;; Move the buffers to the end of buffer list. - (bury-buffer gnus-article-buffer) - (bury-buffer gnus-group-buffer) - (bury-buffer gnus-digest-summary-buffer) - (bury-buffer gnus-digest-buffer)) - (error (set-buffer-modified-p nil) - (kill-buffer digbuf) - ;; This command should not signal an error because the - ;; command is called from hooks. - (ding) (message "Article is not a digest"))) - )) - -(defun gnus-summary-save-article () - "Save this article using default saver function. -The variable `gnus-default-article-saver' specifies the saver function." - (interactive) - (gnus-summary-select-article gnus-save-all-headers gnus-save-all-headers) - (if gnus-default-article-saver - (call-interactively gnus-default-article-saver) - (error "No default saver is defined."))) - -(defun gnus-summary-save-in-rmail (&optional filename) - "Append this article to Rmail file. -Optional argument FILENAME specifies file name. -Directory to save to is default to `gnus-article-save-directory' which -is initialized from the SAVEDIR environment variable." - (interactive) - (gnus-summary-select-article gnus-save-all-headers gnus-save-all-headers) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-excursion - (save-restriction - (widen) - (let ((default-name - (funcall gnus-rmail-save-name - gnus-newsgroup-name - gnus-current-headers - gnus-newsgroup-last-rmail - ))) - (or filename - (setq filename - (read-file-name - (concat "Save article in Rmail file: (default " - (file-name-nondirectory default-name) - ") ") - (file-name-directory default-name) - default-name))) - (gnus-make-directory (file-name-directory filename)) - (gnus-output-to-rmail filename) - ;; Remember the directory name to save articles. - (setq gnus-newsgroup-last-rmail filename) - ))) - )) - -(defun gnus-summary-save-in-mail (&optional filename) - "Append this article to Unix mail file. -Optional argument FILENAME specifies file name. -Directory to save to is default to `gnus-article-save-directory' which -is initialized from the SAVEDIR environment variable." - (interactive) - (gnus-summary-select-article gnus-save-all-headers gnus-save-all-headers) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-excursion - (save-restriction - (widen) - (let ((default-name - (funcall gnus-mail-save-name - gnus-newsgroup-name - gnus-current-headers - gnus-newsgroup-last-mail - ))) - (or filename - (setq filename - (read-file-name - (concat "Save article in Unix mail file: (default " - (file-name-nondirectory default-name) - ") ") - (file-name-directory default-name) - default-name))) - (setq filename - (expand-file-name filename - (and default-name - (file-name-directory default-name)))) - (gnus-make-directory (file-name-directory filename)) - (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (gnus-output-to-rmail filename) - (rmail-output filename 1 t t)) - ;; Remember the directory name to save articles. - (setq gnus-newsgroup-last-mail filename) - ))) - )) - -(defun gnus-summary-save-in-file (&optional filename) - "Append this article to file. -Optional argument FILENAME specifies file name. -Directory to save to is default to `gnus-article-save-directory' which -is initialized from the SAVEDIR environment variable." - (interactive) - (gnus-summary-select-article gnus-save-all-headers gnus-save-all-headers) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-excursion - (save-restriction - (widen) - (let ((default-name - (funcall gnus-file-save-name - gnus-newsgroup-name - gnus-current-headers - gnus-newsgroup-last-file - ))) - (or filename - (setq filename - (read-file-name - (concat "Save article in file: (default " - (file-name-nondirectory default-name) - ") ") - (file-name-directory default-name) - default-name))) - (gnus-make-directory (file-name-directory filename)) - (gnus-output-to-file filename) - ;; Remember the directory name to save articles. - (setq gnus-newsgroup-last-file filename) - ))) - )) - -(defun gnus-summary-save-in-folder (&optional folder) - "Save this article to MH folder (using `rcvstore' in MH library). -Optional argument FOLDER specifies folder name." - (interactive) - (gnus-summary-select-article gnus-save-all-headers gnus-save-all-headers) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction - (widen) - ;; Thanks to yuki@flab.Fujitsu.JUNET and ohm@kaba.junet. - (mh-find-path) - (let ((folder - (or folder - (mh-prompt-for-folder "Save article in" - (funcall gnus-folder-save-name - gnus-newsgroup-name - gnus-current-headers - gnus-newsgroup-last-folder - ) - t - ))) - (errbuf (get-buffer-create " *GNUS rcvstore*"))) - (unwind-protect - (call-process-region (point-min) (point-max) - (expand-file-name "rcvstore" mh-lib) - nil errbuf nil folder) - (set-buffer errbuf) - (if (zerop (buffer-size)) - (message "Article saved in folder: %s" folder) - (message "%s" (buffer-string))) - (kill-buffer errbuf) - (setq gnus-newsgroup-last-folder folder)) - )) - )) - -(defun gnus-summary-pipe-output () - "Pipe this article to subprocess." - (interactive) - ;; Ignore `gnus-save-all-headers' since this is not save command. - ;;(gnus-summary-select-article) - ;; Huuum. Is this right? - (gnus-summary-select-article gnus-save-all-headers gnus-save-all-headers) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction - (widen) - (let ((command (read-string "Shell command on article: " - gnus-last-shell-command))) - (if (string-equal command "") - (setq command gnus-last-shell-command)) - (shell-command-on-region (point-min) (point-max) command nil) - (setq gnus-last-shell-command command) - )) - )) - -(defun gnus-summary-catchup (all &optional quietly) - "Mark all articles not marked as unread in this newsgroup as read. -If prefix argument ALL is non-nil, all articles are marked as read." - (interactive "P") - (if (or quietly - (not gnus-interactive-catchup) ;Without confirmation? - (y-or-n-p - (if all - "Do you really want to mark everything as read? " - "Delete all articles not marked as unread? "))) - (let ((unmarked - (gnus-set-difference gnus-newsgroup-unreads - (if (not all) gnus-newsgroup-marked)))) - (message "") ;Erase "Yes or No" question. - ;; Hidden thread subtrees must be searched for ,too. - (gnus-summary-show-all-threads) - (while unmarked - (gnus-summary-mark-as-read (car unmarked) "C") - (setq unmarked (cdr unmarked)) - )) - )) - -(defun gnus-summary-catchup-to-here () - "Mark all articles before the current one in this newsgroup as read." - (interactive) - (beginning-of-line) - (let ((current (gnus-summary-article-number))) - (beginning-of-buffer) - (while (not (= (gnus-summary-article-number) current)) - (gnus-summary-mark-as-read) - (gnus-summary-next-subject 1)))) - -(defun gnus-summary-catchup-all (&optional quietly) - "Mark all articles in this newsgroup as read." - (interactive) - (gnus-summary-catchup t quietly)) - -(defun gnus-summary-catchup-and-exit (all &optional quietly) - "Mark all articles not marked as unread in this newsgroup as read, then exit. -If prefix argument ALL is non-nil, all articles are marked as read." - (interactive "P") - (if (or quietly - (not gnus-interactive-catchup) ;Without confirmation? - (y-or-n-p - (if all - "Do you really want to mark everything as read? " - "Delete all articles not marked as unread? "))) - (let ((unmarked - (gnus-set-difference gnus-newsgroup-unreads - (if (not all) gnus-newsgroup-marked)))) - (message "") ;Erase "Yes or No" question. - (while unmarked - (gnus-mark-article-as-read (car unmarked)) - (setq unmarked (cdr unmarked))) - ;; Select next newsgroup or exit. - (cond ((eq gnus-auto-select-next 'quietly) - ;; Select next newsgroup quietly. - (gnus-summary-next-group nil)) - (t - (gnus-summary-exit))) - ))) - -(defun gnus-summary-catchup-all-and-exit (&optional quietly) - "Mark all articles in this newsgroup as read, and then exit." - (interactive) - (gnus-summary-catchup-and-exit t quietly)) - -(defun gnus-summary-edit-global-kill () - "Edit a global KILL file." - (interactive) - (setq gnus-current-kill-article (gnus-summary-article-number)) - (gnus-kill-file-edit-file nil) ;Nil stands for global KILL file. - (message - (substitute-command-keys - "Editing a global KILL file (Type \\[gnus-kill-file-exit] to exit)"))) - -(defun gnus-summary-edit-local-kill () - "Edit a local KILL file applied to the current newsgroup." - (interactive) - (setq gnus-current-kill-article (gnus-summary-article-number)) - (gnus-kill-file-edit-file gnus-newsgroup-name) - (message - (substitute-command-keys - "Editing a local KILL file (Type \\[gnus-kill-file-exit] to exit)"))) - -(defun gnus-summary-exit (&optional temporary) - "Exit reading current newsgroup, and then return to group selection mode. -`gnus-exit-group-hook' is called with no arguments if that value is non-nil." - (interactive) - (let ((updated nil) - (gnus-newsgroup-headers gnus-newsgroup-headers) - (gnus-newsgroup-unreads gnus-newsgroup-unreads) - (gnus-newsgroup-unselected gnus-newsgroup-unselected) - (gnus-newsgroup-marked gnus-newsgroup-marked)) - ;; Important internal variables are saved, so we can reenter - ;; Summary buffer even if hook changes them. - (run-hooks 'gnus-exit-group-hook) - (gnus-update-unread-articles gnus-newsgroup-name - (append gnus-newsgroup-unselected - gnus-newsgroup-unreads) - gnus-newsgroup-marked) - ;; T means ignore unsubscribed newsgroups. - (if gnus-use-cross-reference - (setq updated - (gnus-mark-as-read-by-xref gnus-newsgroup-name - gnus-newsgroup-headers - gnus-newsgroup-unreads - (eq gnus-use-cross-reference t) - ))) - ;; Do not switch windows but change the buffer to work. - (set-buffer gnus-group-buffer) - ;; Update cross referenced group info. - (while updated - (gnus-group-update-group (car updated) t) ;Ignore invisible group. - (setq updated (cdr updated))) - (gnus-group-update-group gnus-newsgroup-name)) - ;; Make sure where I was, and go to next newsgroup. - (gnus-group-jump-to-group gnus-newsgroup-name) - (gnus-group-next-unread-group 1) - (if temporary - ;; If exiting temporary, caller should adjust Group mode - ;; buffer point by itself. - nil ;Nothing to do. - ;; Return to Group mode buffer. - (if (get-buffer gnus-summary-buffer) - (bury-buffer gnus-summary-buffer)) - (if (get-buffer gnus-article-buffer) - (bury-buffer gnus-article-buffer)) - (gnus-configure-windows 'newsgroups) - (pop-to-buffer gnus-group-buffer))) - -(defun gnus-summary-quit () - "Quit reading current newsgroup without updating read article info." - (interactive) - (if (y-or-n-p "Do you really wanna quit reading this group? ") - (progn - (message "") ;Erase "Yes or No" question. - ;; Return to Group selection mode. - (if (get-buffer gnus-summary-buffer) - (bury-buffer gnus-summary-buffer)) - (if (get-buffer gnus-article-buffer) - (bury-buffer gnus-article-buffer)) - (gnus-configure-windows 'newsgroups) - (pop-to-buffer gnus-group-buffer) - (gnus-group-jump-to-group gnus-newsgroup-name) ;Make sure where I was. - (gnus-group-next-group 1) ;(gnus-group-next-unread-group 1) - ))) - -(defun gnus-summary-describe-briefly () - "Describe Summary mode commands briefly." - (interactive) - (message - (concat - (substitute-command-keys "\\[gnus-summary-next-page]:Select ") - (substitute-command-keys "\\[gnus-summary-next-unread-article]:Forward ") - (substitute-command-keys "\\[gnus-summary-prev-unread-article]:Backward ") - (substitute-command-keys "\\[gnus-summary-exit]:Exit ") - (substitute-command-keys "\\[gnus-info-find-node]:Run Info ") - (substitute-command-keys "\\[gnus-summary-describe-briefly]:This help") - ))) - - -;;; -;;; GNUS Article Mode -;;; - -(if gnus-article-mode-map - nil - (setq gnus-article-mode-map (make-keymap)) - (suppress-keymap gnus-article-mode-map) - (define-key gnus-article-mode-map " " 'gnus-article-next-page) - (define-key gnus-article-mode-map "\177" 'gnus-article-prev-page) - (define-key gnus-article-mode-map "r" 'gnus-article-refer-article) - (define-key gnus-article-mode-map "o" 'gnus-article-pop-article) - (define-key gnus-article-mode-map "h" 'gnus-article-show-summary) - (define-key gnus-article-mode-map "s" 'gnus-article-show-summary) - (define-key gnus-article-mode-map "?" 'gnus-article-describe-briefly) - (define-key gnus-article-mode-map "\C-c\C-i" 'gnus-info-find-node)) - -(defun gnus-article-mode () - "Major mode for browsing through an article. -All normal editing commands are turned off. -Instead, these commands are available: -\\{gnus-article-mode-map} - -Various hooks for customization: - gnus-article-mode-hook - Entry to this mode calls the value with no arguments, if that - value is non-nil. - - gnus-article-prepare-hook - Called with no arguments after an article is prepared for reading, - if that value is non-nil." - (interactive) - (kill-all-local-variables) - ;; Gee. Why don't you upgrade? - (cond ((boundp 'mode-line-modified) - (setq mode-line-modified "--- ")) - ((listp (default-value 'mode-line-format)) - (setq mode-line-format - (cons "--- " (cdr (default-value 'mode-line-format)))))) - ;; To disable display-time facility. - ;;(make-local-variable 'global-mode-string) - ;;(setq global-mode-string nil) - (setq major-mode 'gnus-article-mode) - (setq mode-name "Article") - (make-local-variable 'minor-mode-alist) - (or (assq 'gnus-show-mime minor-mode-alist) - (setq minor-mode-alist - (cons (list 'gnus-show-mime " MIME") minor-mode-alist))) - (gnus-article-set-mode-line) - (use-local-map gnus-article-mode-map) - (make-local-variable 'page-delimiter) - (setq page-delimiter gnus-page-delimiter) - (make-local-variable 'mail-header-separator) - (setq mail-header-separator "") ;For caesar function. - (buffer-flush-undo (current-buffer)) - (setq buffer-read-only t) ;Disable modification - (run-hooks 'gnus-article-mode-hook)) - -(defun gnus-article-setup-buffer () - "Initialize Article mode buffer." - (or (get-buffer gnus-article-buffer) - (save-excursion - (set-buffer (get-buffer-create gnus-article-buffer)) - (gnus-article-mode)) - )) - -(defun gnus-article-prepare (article &optional all-headers) - "Prepare ARTICLE in Article mode buffer. -ARTICLE can be either a article number or Message-ID. -If optional argument ALL-HEADERS is non-nil, -include the article's whole original header." - ;; Make sure a connection to NNTP server is alive. - (if (not (gnus-server-opened)) - (progn - (gnus-start-news-server) - (gnus-request-group gnus-newsgroup-name))) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil)) - (erase-buffer) - ;; mhspool does not work with Message-ID. So, let's translate - ;; it into an article number as possible as can. This may help - ;; nnspool too. - ;; Note: this conversion must be done here since if the article - ;; is specified by number or message-id has a different meaning - ;; in the following. - (if (let* ((header - (and (stringp article) - (gnus-get-header-by-id article))) - (article - (if header - (nntp-header-number header) article))) - (gnus-request-article article)) - (progn - ;; Prepare article buffer - (insert-buffer-substring nntp-server-buffer) - ;; gnus-have-all-headers must be either T or NIL. - (setq gnus-have-all-headers - (not (not (or all-headers gnus-show-all-headers)))) - (if (and (numberp article) - (not (eq article gnus-current-article))) - ;; Seems me that a new article has been selected. - (progn - ;; gnus-current-article must be an article number. - (setq gnus-last-article gnus-current-article) - (setq gnus-current-article article) -;; (setq gnus-current-headers -;; (gnus-find-header-by-number gnus-newsgroup-headers -;; gnus-current-article)) - (setq gnus-current-headers - (gnus-get-header-by-number gnus-current-article)) - (run-hooks 'gnus-mark-article-hook) - )) - ;; Clear article history only when the article is - ;; retrieved by the article number. - (if (numberp article) - (setq gnus-current-history nil)) - ;; Hooks for modifying contents of the article. This hook - ;; must be called before being narrowed. - (run-hooks 'gnus-article-prepare-hook) - ;; Decode MIME message. - (if (and gnus-show-mime - (gnus-fetch-field "Mime-Version")) - (funcall gnus-show-mime-method)) - ;; Delete unnecessary headers. - (or gnus-have-all-headers - (gnus-article-delete-headers)) - ;; Do page break. - (goto-char (point-min)) - (if gnus-break-pages - (gnus-narrow-to-page)) - ;; Next function must be called after setting - ;; `gnus-current-article' variable and narrowed to page. - (gnus-article-set-mode-line) - ) - ;; There is no such article. - (if (numberp article) - (gnus-summary-mark-as-read article)) - (ding) (message "No such article (may be canceled)")) - ))) - -(defun gnus-article-show-all-headers () - "Show all article headers in Article mode buffer." - (or gnus-have-all-headers - (gnus-article-prepare gnus-current-article t))) - -;;(defun gnus-article-set-mode-line () -;; "Set Article mode line string." -;; (setq mode-line-buffer-identification -;; (list 17 -;; (format "GNUS: %s {%d-%d} %d" -;; gnus-newsgroup-name -;; gnus-newsgroup-begin -;; gnus-newsgroup-end -;; gnus-current-article -;; ))) -;; (set-buffer-modified-p t)) - -;;(defun gnus-article-set-mode-line () -;; "Set Article mode line string." -;; (let ((unmarked -;; (- (length gnus-newsgroup-unreads) -;; (length (gnus-intersection -;; gnus-newsgroup-unreads gnus-newsgroup-marked)))) -;; (unselected -;; (- (length gnus-newsgroup-unselected) -;; (length (gnus-intersection -;; gnus-newsgroup-unselected gnus-newsgroup-marked))))) -;; (setq mode-line-buffer-identification -;; (list 17 -;; (format "GNUS: %s{%d} %s" -;; gnus-newsgroup-name -;; gnus-current-article -;; ;; This is proposed by tale@pawl.rpi.edu. -;; (cond ((and (zerop unmarked) -;; (zerop unselected)) -;; " ") -;; ((zerop unselected) -;; (format "%d more" unmarked)) -;; (t -;; (format "%d(+%d) more" unmarked unselected))) -;; )))) -;; (set-buffer-modified-p t)) - -;; New implementation in gnus 3.14.3 - -(defun gnus-article-set-mode-line () - "Set Article mode line string. -If you don't like it, define your own `gnus-article-set-mode-line'." - (let ((maxlen 15) ;Maximum subject length - (subject - (if gnus-current-headers - (nntp-header-subject gnus-current-headers) ""))) - ;; The value must be a string to escape %-constructs because of subject. - (setq mode-line-buffer-identification - (format "GNUS: %s%s %s%s%s" - gnus-newsgroup-name - (if gnus-current-article - (format "/%d" gnus-current-article) "") - (substring subject 0 (min (length subject) maxlen)) - (if (> (length subject) maxlen) "..." "") - (make-string (max 0 (- 17 (length subject))) ? ) - ))) - (set-buffer-modified-p t)) - -(defun gnus-article-delete-headers () - "Delete unnecessary headers." - (save-excursion - (save-restriction - (goto-char (point-min)) - (narrow-to-region (point-min) - (progn (search-forward "\n\n" nil 'move) (point))) - (goto-char (point-min)) - (and (stringp gnus-ignored-headers) - (while (re-search-forward gnus-ignored-headers nil t) - (beginning-of-line) - (delete-region (point) - (progn (re-search-forward "\n[^ \t]") - (forward-char -1) - (point))))) - ))) - -;; Working on article's buffer - -(defun gnus-article-next-page (lines) - "Show next page of current article. -If end of article, return non-nil. Otherwise return nil. -Argument LINES specifies lines to be scrolled up." - (interactive "P") - (move-to-window-line -1) - ;; Fixed by enami@ptgd.sony.co.jp (enami tsugutomo) - (if (save-excursion - (end-of-line) - (and (pos-visible-in-window-p) ;Not continuation line. - (eobp))) - ;; Nothing in this page. - (if (or (not gnus-break-pages) - (save-excursion - (save-restriction - (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? - t ;Nothing more. - (gnus-narrow-to-page 1) ;Go to next page. - nil - ) - ;; More in this page. - (condition-case () - (scroll-up lines) - (end-of-buffer - ;; Long lines may cause an end-of-buffer error. - (goto-char (point-max)))) - nil - )) - -(defun gnus-article-prev-page (lines) - "Show previous page of current article. -Argument LINES specifies lines to be scrolled down." - (interactive "P") - (move-to-window-line 0) - (if (and gnus-break-pages - (bobp) - (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer? - (progn - (gnus-narrow-to-page -1) ;Go to previous page. - (goto-char (point-max)) - (recenter -1)) - (scroll-down lines))) - -(defun gnus-article-next-digest (nth) - "Move to head of NTH next digested message. -Set mark at end of digested message." - ;; Stop page breaking in digest mode. - (widen) - (end-of-line) - ;; Skip NTH - 1 digest. - ;; Suggested by Khalid Sattar <admin@cs.exeter.ac.uk>. - ;; Digest separator is customizable. - ;; Suggested by Skip Montanaro <montanaro@sprite.crd.ge.com>. - (while (and (> nth 1) - (re-search-forward gnus-digest-separator nil 'move)) - (setq nth (1- nth))) - (if (re-search-forward gnus-digest-separator nil t) - (let ((begin (point))) - ;; Search for end of this message. - (end-of-line) - (if (re-search-forward gnus-digest-separator nil t) - (progn - (search-backward "\n\n") ;This may be incorrect. - (forward-line 1)) - (goto-char (point-max))) - (push-mark) ;Set mark at end of digested message. - (goto-char begin) - (beginning-of-line) - ;; Show From: and Subject: fields. - (recenter 1)) - (message "End of message") - )) - -(defun gnus-article-prev-digest (n) - "Move to head of Nth previous digested message." - ;; Stop page breaking in digest mode. - (widen) - (beginning-of-line) - ;; Skip N - 1 digest. - ;; Suggested by Khalid Sattar <admin@cs.exeter.ac.uk>. - ;; Digest separator is customizable. - ;; Suggested by Skip Montanaro <montanaro@sprite.crd.ge.com>. - (while (and (> n 1) - (re-search-backward gnus-digest-separator nil 'move)) - (setq n (1- n))) - (if (re-search-backward gnus-digest-separator nil t) - (let ((begin (point))) - ;; Search for end of this message. - (end-of-line) - (if (re-search-forward gnus-digest-separator nil t) - (progn - (search-backward "\n\n") ;This may be incorrect. - (forward-line 1)) - (goto-char (point-max))) - (push-mark) ;Set mark at end of digested message. - (goto-char begin) - ;; Show From: and Subject: fields. - (recenter 1)) - (goto-char (point-min)) - (message "Top of message") - )) - -(defun gnus-article-refer-article () - "Read article specified by message-id around point." - (interactive) - (save-window-excursion - (save-excursion - (re-search-forward ">" nil t) ;Move point to end of "<....>". - (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t) - (let ((message-id - (buffer-substring (match-beginning 1) (match-end 1)))) - (set-buffer gnus-summary-buffer) - (gnus-summary-refer-article message-id)) - (error "No references around point")) - ))) - -(defun gnus-article-pop-article () - "Pop up article history." - (interactive) - (save-window-excursion - (set-buffer gnus-summary-buffer) - (gnus-summary-refer-article nil))) - -(defun gnus-article-show-summary () - "Reconfigure windows to show Summary buffer." - (interactive) - (gnus-configure-windows 'article) - (pop-to-buffer gnus-summary-buffer) - (gnus-summary-goto-subject gnus-current-article)) - -(defun gnus-article-describe-briefly () - "Describe Article mode commands briefly." - (interactive) - (message - (concat - (substitute-command-keys "\\[gnus-article-next-page]:Next page ") - (substitute-command-keys "\\[gnus-article-prev-page]:Prev page ") - (substitute-command-keys "\\[gnus-article-show-summary]:Show Summary ") - (substitute-command-keys "\\[gnus-info-find-node]:Run Info ") - (substitute-command-keys "\\[gnus-article-describe-briefly]:This help") - ))) - - -;;; -;;; GNUS KILL-File Mode -;;; - -(if gnus-kill-file-mode-map - nil - (setq gnus-kill-file-mode-map (copy-keymap emacs-lisp-mode-map)) - (define-key gnus-kill-file-mode-map "\C-c\C-k\C-s" 'gnus-kill-file-kill-by-subject) - (define-key gnus-kill-file-mode-map "\C-c\C-k\C-a" 'gnus-kill-file-kill-by-author) - (define-key gnus-kill-file-mode-map "\C-c\C-a" 'gnus-kill-file-apply-buffer) - (define-key gnus-kill-file-mode-map "\C-c\C-e" 'gnus-kill-file-apply-last-sexp) - (define-key gnus-kill-file-mode-map "\C-c\C-c" 'gnus-kill-file-exit) - (define-key gnus-kill-file-mode-map "\C-c\C-i" 'gnus-info-find-node)) - -(defun gnus-kill-file-mode () - "Major mode for editing KILL file. - -In addition to Emacs-Lisp Mode, the following commands are available: - -\\[gnus-kill-file-kill-by-subject] Insert KILL command for current subject. -\\[gnus-kill-file-kill-by-author] Insert KILL command for current author. -\\[gnus-kill-file-apply-buffer] Apply current buffer to selected newsgroup. -\\[gnus-kill-file-apply-last-sexp] Apply sexp before point to selected newsgroup. -\\[gnus-kill-file-exit] Save file and exit editing KILL file. -\\[gnus-info-find-node] Read Info about KILL file. - - A KILL file contains Lisp expressions to be applied to a selected -newsgroup. The purpose is to mark articles as read on the basis of -some set of regexps. A global KILL file is applied to every newsgroup, -and a local KILL file is applied to a specified newsgroup. Since a -global KILL file is applied to every newsgroup, for better performance -use a local one. - - A KILL file can contain any kind of Emacs Lisp expressions expected -to be evaluated in the Summary buffer. Writing Lisp programs for this -purpose is not so easy because the internal working of GNUS must be -well-known. For this reason, GNUS provides a general function which -does this easily for non-Lisp programmers. - - The `gnus-kill' function executes commands available in Summary Mode -by their key sequences. `gnus-kill' should be called with FIELD, -REGEXP and optional COMMAND and ALL. FIELD is a string representing -the header field or an empty string. If FIELD is an empty string, the -entire article body is searched for. REGEXP is a string which is -compared with FIELD value. COMMAND is a string representing a valid -key sequence in Summary mode or Lisp expression. COMMAND defaults to -\(gnus-summary-mark-as-read nil \"X\"). Make sure that COMMAND is -executed in the Summary buffer. If the second optional argument ALL -is non-nil, the COMMAND is applied to articles which are already -marked as read or unread. Articles which are marked are skipped over -by default. - - For example, if you want to mark articles of which subjects contain -the string `AI' as read, a possible KILL file may look like: - - (gnus-kill \"Subject\" \"AI\") - - If you want to mark articles with `D' instead of `X', you can use -the following expression: - - (gnus-kill \"Subject\" \"AI\" \"d\") - -\(Here we assume the command `gnus-summary-mark-as-read-forward' is -assigned to `d' in Summary Mode.) - - It is possible to delete unnecessary headers which are marked with -`X' in a KILL file as follows: - - (gnus-expunge \"X\") - - If the Summary buffer is empty after applying KILL files, GNUS will -exit the selected newsgroup normally. If headers which are marked -with `D' are deleted in a KILL file, it is impossible to read articles -which are marked as read in the previous GNUS sessions. Marks other -than `D' should be used for articles which should really be deleted. - -Entry to this mode calls `emacs-lisp-mode-hook' and -`gnus-kill-file-mode-hook' with no arguments, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map gnus-kill-file-mode-map) - (set-syntax-table emacs-lisp-mode-syntax-table) - (setq major-mode 'gnus-kill-file-mode) - (setq mode-name "KILL-File") - (lisp-mode-variables nil) - (run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook)) - -(defun gnus-kill-file-edit-file (newsgroup) - "Begin editing a KILL file of NEWSGROUP. -If NEWSGROUP is nil, the global KILL file is selected." - (interactive "sNewsgroup: ") - (let ((file (gnus-newsgroup-kill-file newsgroup))) - (gnus-make-directory (file-name-directory file)) - ;; Save current window configuration if this is first invocation. - (or (and (get-file-buffer file) - (get-buffer-window (get-file-buffer file))) - (setq gnus-winconf-kill-file (current-window-configuration))) - ;; Hack windows. - (let ((buffer (find-file-noselect file))) - (cond ((get-buffer-window buffer) - (pop-to-buffer buffer)) - ((eq major-mode 'gnus-group-mode) - (gnus-configure-windows '(1 0 0)) ;Take all windows. - (pop-to-buffer gnus-group-buffer) - (let ((gnus-summary-buffer buffer)) - (gnus-configure-windows '(1 1 0)) ;Split into two. - (pop-to-buffer buffer))) - ((eq major-mode 'gnus-summary-mode) - (gnus-configure-windows 'article) - (pop-to-buffer gnus-article-buffer) - (bury-buffer gnus-article-buffer) - (switch-to-buffer buffer)) - (t ;No good rules. - (find-file-other-window file)) - )) - (gnus-kill-file-mode) - )) - -(defun gnus-kill-file-kill-by-subject () - "Insert KILL command for current subject." - (interactive) - (insert - (format "(gnus-kill \"Subject\" %s)\n" - (prin1-to-string - (if gnus-current-kill-article - (regexp-quote - (nntp-header-subject - ;; No need to speed up this command. - ;;(gnus-get-header-by-number gnus-current-kill-article) - (gnus-find-header-by-number gnus-newsgroup-headers - gnus-current-kill-article))) - ""))))) - -(defun gnus-kill-file-kill-by-author () - "Insert KILL command for current author." - (interactive) - (insert - (format "(gnus-kill \"From\" %s)\n" - (prin1-to-string - (if gnus-current-kill-article - (regexp-quote - (nntp-header-from - ;; No need to speed up this command. - ;;(gnus-get-header-by-number gnus-current-kill-article) - (gnus-find-header-by-number gnus-newsgroup-headers - gnus-current-kill-article))) - ""))))) - -(defun gnus-kill-file-apply-buffer () - "Apply current buffer to current newsgroup." - (interactive) - (if (and gnus-current-kill-article - (get-buffer gnus-summary-buffer)) - ;; Assume newsgroup is selected. - (let ((string (concat "(progn \n" (buffer-string) "\n)" ))) - (save-excursion - (save-window-excursion - (pop-to-buffer gnus-summary-buffer) - (eval (car (read-from-string string)))))) - (ding) (message "No newsgroup is selected."))) - -(defun gnus-kill-file-apply-last-sexp () - "Apply sexp before point in current buffer to current newsgroup." - (interactive) - (if (and gnus-current-kill-article - (get-buffer gnus-summary-buffer)) - ;; Assume newsgroup is selected. - (let ((string - (buffer-substring - (save-excursion (forward-sexp -1) (point)) (point)))) - (save-excursion - (save-window-excursion - (pop-to-buffer gnus-summary-buffer) - (eval (car (read-from-string string)))))) - (ding) (message "No newsgroup is selected."))) - -(defun gnus-kill-file-exit () - "Save a KILL file, then return to the previous buffer." - (interactive) - (save-buffer) - (let ((killbuf (current-buffer))) - ;; We don't want to return to Article buffer. - (and (get-buffer gnus-article-buffer) - (bury-buffer (get-buffer gnus-article-buffer))) - ;; Delete the KILL file windows. - (delete-windows-on killbuf) - ;; Restore last window configuration if available. - (and gnus-winconf-kill-file - (set-window-configuration gnus-winconf-kill-file)) - (setq gnus-winconf-kill-file nil) - ;; Kill the KILL file buffer. Suggested by tale@pawl.rpi.edu. - (kill-buffer killbuf))) - - -;;; -;;; Utility functions -;;; - -;; Basic ideas by emv@math.lsa.umich.edu (Edward Vielmetti) - -(defun gnus-batch-kill () - "Run batched KILL. -Usage: emacs -batch -l gnus -f gnus-batch-kill NEWSGROUP ..." - (if (not noninteractive) - (error "gnus-batch-kill is to be used only with -batch")) - (let* ((group nil) - (subscribed nil) - (newsrc nil) - (yes-and-no - (gnus-parse-n-options - (apply (function concat) - (mapcar (function (lambda (g) (concat g " "))) - command-line-args-left)))) - (yes (car yes-and-no)) - (no (cdr yes-and-no)) - ;; Disable verbose message. - (gnus-novice-user nil) - (gnus-large-newsgroup nil) - (nntp-large-newsgroup nil)) - ;; Eat all arguments. - (setq command-line-args-left nil) - ;; Startup GNUS. - (gnus) - ;; Apply kills to specified newsgroups in command line arguments. - (setq newsrc (copy-sequence gnus-newsrc-assoc)) - (while newsrc - (setq group (car (car newsrc))) - (setq subscribed (nth 1 (car newsrc))) - (setq newsrc (cdr newsrc)) - (if (and subscribed - (not (zerop (nth 1 (gnus-gethash group gnus-unread-hashtb)))) - (if yes - (string-match yes group) t) - (or (null no) - (not (string-match no group)))) - (progn - (gnus-summary-read-group group nil t) - (if (eq (current-buffer) (get-buffer gnus-summary-buffer)) - (gnus-summary-exit t)) - )) - ) - ;; Finally, exit Emacs. - (set-buffer gnus-group-buffer) - (gnus-group-exit) - )) - -;; For saving articles - -(defun gnus-Numeric-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is nil, it is ~/News/News.group/num. -Otherwise, it is like ~/News/news/group/num." - (let ((default - (expand-file-name - (concat (if gnus-use-long-file-name - (gnus-capitalize-newsgroup newsgroup) - (gnus-newsgroup-directory-form newsgroup)) - "/" (int-to-string (nntp-header-number headers))) - (or gnus-article-save-directory "~/News")))) - (if (and last-file - (string-equal (file-name-directory default) - (file-name-directory last-file)) - (string-match "^[0-9]+$" (file-name-nondirectory last-file))) - default - (or last-file default)))) - -(defun gnus-numeric-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is nil, it is ~/News/news.group/num. -Otherwise, it is like ~/News/news/group/num." - (let ((default - (expand-file-name - (concat (if gnus-use-long-file-name - newsgroup - (gnus-newsgroup-directory-form newsgroup)) - "/" (int-to-string (nntp-header-number headers))) - (or gnus-article-save-directory "~/News")))) - (if (and last-file - (string-equal (file-name-directory default) - (file-name-directory last-file)) - (string-match "^[0-9]+$" (file-name-nondirectory last-file))) - default - (or last-file default)))) - -(defun gnus-Plain-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is nil, it is ~/News/News.group. -Otherwise, it is like ~/News/news/group/news." - (or last-file - (expand-file-name - (if gnus-use-long-file-name - (gnus-capitalize-newsgroup newsgroup) - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) - (or gnus-article-save-directory "~/News")))) - -(defun gnus-plain-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is nil, it is ~/News/news.group. -Otherwise, it is like ~/News/news/group/news." - (or last-file - (expand-file-name - (if gnus-use-long-file-name - newsgroup - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) - (or gnus-article-save-directory "~/News")))) - -(defun gnus-Folder-save-name (newsgroup headers &optional last-folder) - "Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER. -If variable `gnus-use-long-file-name' is nil, it is +News.group. -Otherwise, it is like +news/group." - (or last-folder - (concat "+" - (if gnus-use-long-file-name - (gnus-capitalize-newsgroup newsgroup) - (gnus-newsgroup-directory-form newsgroup))))) - -(defun gnus-folder-save-name (newsgroup headers &optional last-folder) - "Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER. -If variable `gnus-use-long-file-name' is nil, it is +news.group. -Otherwise, it is like +news/group." - (or last-folder - (concat "+" - (if gnus-use-long-file-name - newsgroup - (gnus-newsgroup-directory-form newsgroup))))) - -;; For KILL files - -(defun gnus-apply-kill-file () - "Apply KILL file to the current newsgroup." - ;; Apply the global KILL file. - (load (gnus-newsgroup-kill-file nil) t nil t) - ;; And then apply the local KILL file. - (load (gnus-newsgroup-kill-file gnus-newsgroup-name) t nil t)) - -(defun gnus-Newsgroup-kill-file (newsgroup) - "Return the name of a KILL file of NEWSGROUP. -If NEWSGROUP is nil, return the global KILL file instead." - (cond ((or (null newsgroup) - (string-equal newsgroup "")) - ;; The global KILL file is placed at top of the directory. - (expand-file-name gnus-kill-file-name - (or gnus-kill-files-directory "~/News"))) - (gnus-use-long-file-name - ;; Append ".KILL" to capitalized newsgroup name. - (expand-file-name (concat (gnus-capitalize-newsgroup newsgroup) - "." gnus-kill-file-name) - (or gnus-kill-files-directory "~/News"))) - (t - ;; Place "KILL" under the hierarchical directory. - (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) - "/" gnus-kill-file-name) - (or gnus-kill-files-directory "~/News"))) - )) - -(defun gnus-newsgroup-kill-file (newsgroup) - "Return the name of a KILL file of NEWSGROUP. -If NEWSGROUP is nil, return the global KILL file instead." - (cond ((or (null newsgroup) - (string-equal newsgroup "")) - ;; The global KILL file is placed at top of the directory. - (expand-file-name gnus-kill-file-name - (or gnus-kill-files-directory "~/News"))) - (gnus-use-long-file-name - ;; Append ".KILL" to newsgroup name. - (expand-file-name (concat newsgroup "." gnus-kill-file-name) - (or gnus-kill-files-directory "~/News"))) - (t - ;; Place "KILL" under the hierarchical directory. - (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) - "/" gnus-kill-file-name) - (or gnus-kill-files-directory "~/News"))) - )) - -;; For subscribing new newsgroup - -(defun gnus-subscribe-randomly (newsgroup) - "Subscribe new NEWSGROUP and insert it at the beginning of newsgroups." - (gnus-subscribe-newsgroup newsgroup - (car (car gnus-newsrc-assoc)))) - -(defun gnus-subscribe-alphabetically (newgroup) - "Subscribe new NEWSGROUP and insert it in strict alphabetic order." - ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams) - (let ((groups gnus-newsrc-assoc) - (before nil)) - (while (and (not before) groups) - (if (string< newgroup (car (car groups))) - (setq before (car (car groups))) - (setq groups (cdr groups)))) - (gnus-subscribe-newsgroup newgroup before) - )) - -(defun gnus-subscribe-hierarchically (newgroup) - "Subscribe new NEWSGROUP and insert it in hierarchical newsgroup order." - ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams) - (save-excursion - (set-buffer (find-file-noselect gnus-current-startup-file)) - (let ((groupkey newgroup) - (before nil)) - (while (and (not before) groupkey) - (goto-char (point-min)) - (let ((groupkey-re - (concat "^\\(" (regexp-quote groupkey) ".*\\)[!:]"))) - (while (and (re-search-forward groupkey-re nil t) - (progn - (setq before (buffer-substring - (match-beginning 1) (match-end 1))) - (string< before newgroup))) - )) - ;; Remove tail of newsgroup name (eg. a.b.c -> a.b) - (setq groupkey - (if (string-match "^\\(.*\\)\\.[^.]+$" groupkey) - (substring groupkey (match-beginning 1) (match-end 1))))) - (gnus-subscribe-newsgroup newgroup before) - ))) - -(defun gnus-subscribe-interactively (newsgroup) - "Subscribe new NEWSGROUP interactively. -It is inserted in hierarchical newsgroup order if subscribed. -Unless, it is killed." - (if (y-or-n-p (format "Subscribe new newsgroup: %s " newsgroup)) - (gnus-subscribe-hierarchically newsgroup) - ;; Save in kill-ring - (gnus-subscribe-newsgroup newsgroup) - (gnus-kill-newsgroup newsgroup))) - -(defun gnus-subscribe-newsgroup (newsgroup &optional next) - "Subscribe new NEWSGROUP. -If optional argument NEXT is non-nil, it is inserted before NEXT." - (gnus-insert-newsgroup (list newsgroup t) next) - (message "Subscribe newsgroup: %s" newsgroup)) - -;; For directories - -(defun gnus-newsgroup-directory-form (newsgroup) - "Make hierarchical directory name from NEWSGROUP name." - (let ((newsgroup (substring newsgroup 0)) ;Copy string. - (len (length newsgroup)) - (idx 0)) - ;; Replace all occurrences of `.' with `/'. - (while (< idx len) - (if (= (aref newsgroup idx) ?.) - (aset newsgroup idx ?/)) - (setq idx (1+ idx))) - newsgroup - )) - -(defun gnus-make-directory (directory) - "Make DIRECTORY recursively." - (let ((directory (expand-file-name directory default-directory))) - (or (file-exists-p directory) - (gnus-make-directory-1 "" directory)) - )) - -(defun gnus-make-directory-1 (head tail) - (cond ((string-match "^/\\([^/]+\\)" tail) - ;; ange-ftp interferes with calling match-* after - ;; calling file-name-as-directory. - (let ((beg (match-beginning 1)) - (end (match-end 1))) - (setq head (concat (file-name-as-directory head) - (substring tail beg end))) - (or (file-exists-p head) - (call-process "mkdir" nil nil nil head)) - (gnus-make-directory-1 head (substring tail end)))) - ((string-equal tail "") t) - )) - -(defun gnus-capitalize-newsgroup (newsgroup) - "Capitalize NEWSGROUP name with treating `.' and `-' as part of words." - ;; Suggested by "Jonathan I. Kamens" <jik@pit-manager.MIT.EDU>. - (let ((current-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table (copy-syntax-table current-syntax-table)) - (modify-syntax-entry ?- "w") - (modify-syntax-entry ?. "w") - (capitalize newsgroup)) - (set-syntax-table current-syntax-table)))) - -(defun gnus-simplify-subject (subject &optional re-only) - "Remove `Re:' and words in parentheses. -If optional argument RE-ONLY is non-nil, strip `Re:' only." - (let ((case-fold-search t)) ;Ignore case. - ;; Remove `Re:' and `Re^N:'. - (if (string-match "\\`\\(re\\(\\^[0-9]+\\)?:[ \t]+\\)+" subject) - (setq subject (substring subject (match-end 0)))) - ;; Remove words in parentheses from end. - (or re-only - (while (string-match "[ \t\n]*([^()]*)[ \t\n]*\\'" subject) - (setq subject (substring subject 0 (match-beginning 0))))) - ;; Return subject string. - subject - )) - -(defun gnus-optional-lines-and-from (header) - "Return a string like `NNN:AUTHOR' from HEADER." - (let ((name-length (length "umerin@photon"))) - (substring (format "%3d:%s" - ;; Lines of the article. - ;; Suggested by dana@bellcore.com. - (nntp-header-lines header) - ;; Its author. - (concat (mail-strip-quoted-names - (nntp-header-from header)) - (make-string name-length ? ))) - ;; 4 stands for length of `NNN:'. - 0 (+ 4 name-length)))) - -(defun gnus-optional-lines (header) - "Return a string like `NNN' from HEADER." - (format "%4d" (nntp-header-lines header))) - -;; Basic ideas by flee@cs.psu.edu (Felix Lee) - -(defun gnus-keysort-headers (predicate key &optional reverse) - "Sort current headers by PREDICATE using a value passed by KEY safely. -*Safely* means C-g quitting is disabled during sort. -Optional argument REVERSE means reverse order." - (let ((inhibit-quit t)) - (setq gnus-newsgroup-headers - (if reverse - (nreverse - (gnus-keysort (nreverse gnus-newsgroup-headers) predicate key)) - (gnus-keysort gnus-newsgroup-headers predicate key))) - ;; Make sure we don't have to call - ;; gnus-clear-hashtables-for-newsgroup-headers to clear hash - ;; tables for the variable gnus-newsgroup-headers since no new - ;; entry is added to nor deleted from the variable. - )) - -(defun gnus-keysort (list predicate key) - "Sort LIST by PREDICATE using a value passed by KEY." - (mapcar (function cdr) - (sort (mapcar (function (lambda (a) (cons (funcall key a) a))) list) - (function (lambda (a b) - (funcall predicate (car a) (car b))))))) - -(defun gnus-sort-headers (predicate &optional reverse) - "Sort current headers by PREDICATE safely. -*Safely* means C-g quitting is disabled during sort. -Optional argument REVERSE means reverse order." - (let ((inhibit-quit t)) - (setq gnus-newsgroup-headers - (if reverse - (nreverse (sort (nreverse gnus-newsgroup-headers) predicate)) - (sort gnus-newsgroup-headers predicate))) - ;; Make sure we don't have to call - ;; gnus-clear-hashtables-for-newsgroup-headers to clear hash - ;; tables for the variable gnus-newsgroup-headers since no new - ;; entry is added to nor deleted from the variable. - )) - -(defun gnus-string-lessp (a b) - "Return T if first arg string is less than second in lexicographic order. -If `case-fold-search' is non-nil, case of letters is ignored." - (if case-fold-search - (string-lessp (downcase a) (downcase b)) - (string-lessp a b))) - -(defun gnus-date-lessp (date1 date2) - "Return T if DATE1 is earlyer than DATE2." - (string-lessp (gnus-sortable-date date1) - (gnus-sortable-date date2))) - -(defun gnus-sortable-date (date) - "Convert DATE into a string that can be sorted with `string-lessp'. -Timezone package is used." - (let* ((date (timezone-fix-time date nil nil)) ;[Y M D H M S] - (year (aref date 0)) - (month (aref date 1)) - (day (aref date 2))) - (timezone-make-sortable-date year month day - (timezone-make-time-string - (aref date 3) (aref date 4) (aref date 5))) - )) - -;;(defun gnus-sortable-date (date) -;; "Make sortable string by string-lessp from DATE." -;; (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3") -;; ("APR" . " 4")("MAY" . " 5")("JUN" . " 6") -;; ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9") -;; ("OCT" . "10")("NOV" . "11")("DEC" . "12"))) -;; (date (or date ""))) -;; ;; Can understand the following styles: -;; ;; (1) 14 Apr 89 03:20:12 GMT -;; ;; (2) Fri, 17 Mar 89 4:01:33 GMT -;; (if (string-match -;; "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) \\([0-9:]+\\)" date) -;; (concat -;; ;; Year -;; (substring date (match-beginning 3) (match-end 3)) -;; ;; Month -;; (cdr -;; (assoc -;; (upcase (substring date (match-beginning 2) (match-end 2))) month)) -;; ;; Day -;; (format "%2d" (string-to-int -;; (substring date -;; (match-beginning 1) (match-end 1)))) -;; ;; Time -;; (substring date (match-beginning 4) (match-end 4))) -;; ;; Cannot understand DATE string. -;; date -;; ) -;; )) - -(defun gnus-fetch-field (field) - "Return the value of the header FIELD of current article." - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (narrow-to-region (point-min) - (progn (search-forward "\n\n" nil 'move) (point))) - (mail-fetch-field field)))) - -(defalias 'gnus-expunge 'gnus-summary-delete-marked-with) - -(defun gnus-kill (field regexp &optional command all) - "If FIELD of an article matches REGEXP, execute COMMAND. -Optional 1st argument COMMAND is default to - (gnus-summary-mark-as-read nil \"X\"). -If optional 2nd argument ALL is non-nil, articles marked are also applied to. -If FIELD is an empty string (or nil), entire article body is searched for. -COMMAND must be a Lisp expression or a string representing a key sequence." - ;; We don't want to change current point nor window configuration. - (save-excursion - (save-window-excursion - ;; Selected window must be Summary buffer to execute keyboard - ;; macros correctly. See command_loop_1. - (switch-to-buffer gnus-summary-buffer 'norecord) - (goto-char (point-min)) ;From the beginning. - (if (null command) - (setq command '(gnus-summary-mark-as-read nil "X"))) - (gnus-execute field regexp command nil (not all)) - ))) - -(defun gnus-execute (field regexp form &optional backward ignore-marked) - "If FIELD of article header matches REGEXP, execute lisp FORM (or a string). -If FIELD is an empty string (or nil), entire article body is searched for. -If optional 1st argument BACKWARD is non-nil, do backward instead. -If optional 2nd argument IGNORE-MARKED is non-nil, ignore articles -marked as read or unread." - (let ((function nil) - (header nil) - (article nil)) - (if (string-equal field "") - (setq field nil)) - (if (null field) - nil - (or (stringp field) - (setq field (symbol-name field))) - ;; Get access function of header filed. - (setq function (intern-soft (concat "gnus-header-" (downcase field)))) - (if (and function (fboundp function)) - (setq function (symbol-function function)) - (error "Unknown header field: \"%s\"" field))) - ;; Make FORM funcallable. - (if (and (listp form) (not (eq (car form) 'lambda))) - (setq form (list 'lambda nil form))) - ;; Starting from the current article. - (or (and ignore-marked - ;; Articles marked as read and unread should be ignored. - (setq article (gnus-summary-article-number)) - (or (not (memq article gnus-newsgroup-unreads)) ;Marked as read. - (memq article gnus-newsgroup-marked) ;Marked as unread. - )) - (gnus-execute-1 function regexp form)) - (while (gnus-summary-search-subject backward ignore-marked nil) - (gnus-execute-1 function regexp form)) - )) - -(defun gnus-execute-1 (function regexp form) - (save-excursion - ;; The point of Summary buffer must be saved during execution. - (let ((article (gnus-summary-article-number))) - (if (null article) - nil ;Nothing to do. - (if function - ;; Compare with header field. - (let (;;(header (gnus-find-header-by-number - ;; gnus-newsgroup-headers article)) - (header (gnus-get-header-by-number article)) - (value nil)) - (and header - (progn - (setq value (funcall function header)) - ;; Number (Lines:) or symbol must be converted to string. - (or (stringp value) - (setq value (prin1-to-string value))) - (string-match regexp value)) - (if (stringp form) ;Keyboard macro. - (execute-kbd-macro form) - (funcall form)))) - ;; Search article body. - (let ((gnus-current-article nil) ;Save article pointer. - (gnus-last-article nil) - (gnus-break-pages nil) ;No need to break pages. - (gnus-mark-article-hook nil)) ;Inhibit marking as read. - (message "Searching for article: %d..." article) - (gnus-article-setup-buffer) - (gnus-article-prepare article t) - (if (save-excursion - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (re-search-forward regexp nil t)) - (if (stringp form) ;Keyboard macro. - (execute-kbd-macro form) - (funcall form)))) - )) - ))) - -;;; caesar-region written by phr@prep.ai.mit.edu Nov 86 -;;; modified by tower@prep Nov 86 -;;; Modified by umerin@flab.flab.Fujitsu.JUNET for ROT47. - -(defun gnus-caesar-region (&optional n) - "Caesar rotation of region by N, default 13, for decrypting netnews. -ROT47 will be performed for Japanese text in any case." - (interactive (if current-prefix-arg ; Was there a prefix arg? - (list (prefix-numeric-value current-prefix-arg)) - (list nil))) - (cond ((not (numberp n)) (setq n 13)) - (t (setq n (mod n 26)))) ;canonicalize N - (if (not (zerop n)) ; no action needed for a rot of 0 - (progn - (if (or (not (boundp 'caesar-translate-table)) - (/= (aref caesar-translate-table ?a) (+ ?a n))) - (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) - (message "Building caesar-translate-table...") - (setq caesar-translate-table (make-vector 256 0)) - (while (< i 256) - (aset caesar-translate-table i i) - (setq i (1+ i))) - (setq lower (concat lower lower) upper (upcase lower) i 0) - (while (< i 26) - (aset caesar-translate-table (+ ?a i) (aref lower (+ i n))) - (aset caesar-translate-table (+ ?A i) (aref upper (+ i n))) - (setq i (1+ i))) - ;; ROT47 for Japanese text. - ;; Thanks to ichikawa@flab.fujitsu.junet. - (setq i 161) - (let ((t1 (logior ?O 128)) - (t2 (logior ?! 128)) - (t3 (logior ?~ 128))) - (while (< i 256) - (aset caesar-translate-table i - (let ((v (aref caesar-translate-table i))) - (if (<= v t1) (if (< v t2) v (+ v 47)) - (if (<= v t3) (- v 47) v)))) - (setq i (1+ i)))) - (message "Building caesar-translate-table...done"))) - (let ((from (region-beginning)) - (to (region-end)) - (i 0) str len) - (setq str (buffer-substring from to)) - (setq len (length str)) - (while (< i len) - (aset str i (aref caesar-translate-table (aref str i))) - (setq i (1+ i))) - (goto-char from) - (delete-region from to) - (insert str))))) - -;; Functions accessing headers. -;; Functions are more convenient than macros in some case. - -(defun gnus-header-number (header) - "Return article number in HEADER." - (nntp-header-number header)) - -(defun gnus-header-subject (header) - "Return subject string in HEADER." - (nntp-header-subject header)) - -(defun gnus-header-from (header) - "Return author string in HEADER." - (nntp-header-from header)) - -(defun gnus-header-xref (header) - "Return xref string in HEADER." - (nntp-header-xref header)) - -(defun gnus-header-lines (header) - "Return lines in HEADER." - (nntp-header-lines header)) - -(defun gnus-header-date (header) - "Return date in HEADER." - (nntp-header-date header)) - -(defun gnus-header-id (header) - "Return Id in HEADER." - (nntp-header-id header)) - -(defun gnus-header-references (header) - "Return references in HEADER." - (nntp-header-references header)) - - -;;; -;;; Article savers. -;;; - -(defun gnus-output-to-rmail (file-name) - "Append the current article to an Rmail file named FILE-NAME." - (require 'rmail) - ;; Most of these codes are borrowed from rmailout.el. - (setq file-name (expand-file-name file-name)) - (setq rmail-default-rmail-file file-name) - (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *GNUS-output*"))) - (save-excursion - (or (get-file-buffer file-name) - (file-exists-p file-name) - (if (yes-or-no-p - (concat "\"" file-name "\" does not exist, create it? ")) - (let ((file-buffer (create-file-buffer file-name))) - (save-excursion - (set-buffer file-buffer) - (rmail-insert-rmail-file-header) - (let ((require-final-newline nil)) - (write-region (point-min) (point-max) file-name t 1))) - (kill-buffer file-buffer)) - (error "Output file does not exist"))) - (set-buffer tmpbuf) - (buffer-flush-undo (current-buffer)) - (erase-buffer) - (insert-buffer-substring artbuf) - (gnus-convert-article-to-rmail) - ;; Decide whether to append to a file or to an Emacs buffer. - (let ((outbuf (get-file-buffer file-name))) - (if (not outbuf) - (append-to-file (point-min) (point-max) file-name) - ;; File has been visited, in buffer OUTBUF. - (set-buffer outbuf) - (let ((buffer-read-only nil) - (msg (and (boundp 'rmail-current-message) - rmail-current-message))) - ;; If MSG is non-nil, buffer is in RMAIL mode. - (if msg - (progn (widen) - (narrow-to-region (point-max) (point-max)))) - (insert-buffer-substring tmpbuf) - (if msg - (progn - (goto-char (point-min)) - (widen) - (search-backward "\^_") - (narrow-to-region (point) (point-max)) - (goto-char (1+ (point-min))) - (rmail-count-new-messages t) - (rmail-show-message msg)))))) - ) - (kill-buffer tmpbuf) - )) - -(defun gnus-output-to-file (file-name) - "Append the current article to a file named FILE-NAME." - (setq file-name (expand-file-name file-name)) - (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *GNUS-output*"))) - (save-excursion - (set-buffer tmpbuf) - (buffer-flush-undo (current-buffer)) - (erase-buffer) - (insert-buffer-substring artbuf) - ;; Append newline at end of the buffer as separator, and then - ;; save it to file. - (goto-char (point-max)) - (insert "\n") - (append-to-file (point-min) (point-max) file-name)) - (kill-buffer tmpbuf) - )) - -(defun gnus-convert-article-to-rmail () - "Convert article in current buffer to Rmail message format." - (let ((buffer-read-only nil)) - ;; Convert article directly into Babyl format. - ;; Suggested by Rob Austein <sra@lcs.mit.edu> - (goto-char (point-min)) - (insert "\^L\n0, unseen,,\n*** EOOH ***\n") - (while (search-forward "\n\^_" nil t) ;single char - (replace-match "\n^_")) ;2 chars: "^" and "_" - (goto-char (point-max)) - (insert "\^_"))) - -;;(defun gnus-convert-article-to-rmail () -;; "Convert article in current buffer to Rmail message format." -;; (let ((buffer-read-only nil)) -;; ;; Insert special header of Unix mail. -;; (goto-char (point-min)) -;; (insert "From " -;; (or (mail-strip-quoted-names (mail-fetch-field "from")) -;; "unknown") -;; " " (current-time-string) "\n") -;; ;; Stop quoting `From' since this seems unnecessary in most cases. -;; ;; ``Quote'' "\nFrom " as "\n>From " -;; ;;(while (search-forward "\nFrom " nil t) -;; ;; (forward-char -5) -;; ;; (insert ?>)) -;; ;; Convert article to babyl format. -;; (rmail-convert-to-babyl-format) -;; )) - - -;;; -;;; Internal functions. -;;; - -(defun gnus-start-news-server (&optional confirm) - "Open network stream to remote NNTP server. -If optional argument CONFIRM is non-nil, ask you host that NNTP server -is running even if it is defined. -Run `gnus-open-server-hook' just before opening news server." - (if (gnus-server-opened) - ;; Stream is already opened. - nil - ;; Open NNTP server. - (if (or confirm - (null gnus-nntp-server)) - ;; If someone has set the service to nil, then this should always - ;; be the local host. - (if gnus-nntp-service - (if (and (boundp 'gnus-secondary-servers) gnus-secondary-servers) - ;; Read server name with completion. - (setq gnus-nntp-server - (completing-read "NNTP server: " - (cons (list gnus-nntp-server) - gnus-secondary-servers) - nil nil gnus-nntp-server)) - (setq gnus-nntp-server - (read-string "NNTP server: " gnus-nntp-server))) - (setq gnus-nntp-server ""))) - ;; If no server name is given, local host is assumed. - (if (or (string-equal gnus-nntp-server "") - (string-equal gnus-nntp-server "::")) ;RMS preference. - (setq gnus-nntp-server (system-name))) - ;; gnus-nntp-server must be either (system-name), ':DIRECTORY', or - ;; nntp server name. I mean '::' cannot be a value of - ;; gnus-nntp-server. - (cond ((and (null gnus-nntp-service) - (string-equal gnus-nntp-server (system-name))) - (require 'nnspool) - (gnus-define-access-method 'nnspool) - (message "Looking up local news spool...")) - ((string-match ":" gnus-nntp-server) - ;; :DIRECTORY - (require 'mhspool) - (gnus-define-access-method 'mhspool) - (message "Looking up private directory...")) - (t - (gnus-define-access-method 'nntp) - (message "Connecting to NNTP server on %s..." gnus-nntp-server))) - (run-hooks 'gnus-open-server-hook) - (cond ((gnus-server-opened) ;Maybe opened in gnus-open-server-hook. - (message "")) - ((gnus-open-server gnus-nntp-server gnus-nntp-service) - (message "")) - (t - (error "%s" - (gnus-nntp-message - (format "Cannot open NNTP server on %s" gnus-nntp-server))))) - )) - -;; Dummy functions used only once. Should return nil. -(defun gnus-server-opened () nil) -(defun gnus-close-server () nil) - -(defun gnus-nntp-message (&optional message) - "Return a message returned from NNTP server. -If no message is available and optional MESSAGE is given, return it." - (let ((status (gnus-status-message)) - (message (or message ""))) - (if (and (stringp status) - (> (length status) 0)) - status message))) - -(defun gnus-define-access-method (method &optional access-methods) - "Define access functions for the access METHOD. -Methods definition is taken from optional argument ACCESS-METHODS or -the variable `gnus-access-methods'." - (let ((bindings - (cdr (assoc method (or access-methods gnus-access-methods))))) - (if (null bindings) - (error "Unknown access method: %s" method) - ;; Should not use symbol-function here since overload does not work. - (while bindings - ;; Alist syntax is different from that of 3.14.3. - (fset (car (car bindings)) (car (cdr (car bindings)))) - (setq bindings (cdr bindings))) - ))) - -(defun gnus-select-newsgroup (group &optional show-all) - "Select newsgroup GROUP. -If optional argument SHOW-ALL is non-nil, all of articles in the group -are selected." - ;; Make sure a connection to NNTP server is alive. - (gnus-start-news-server) - (if (gnus-request-group group) - (let ((articles nil)) - (setq gnus-newsgroup-name group) - (setq gnus-newsgroup-unreads - (gnus-uncompress-sequence - (nthcdr 2 (gnus-gethash group gnus-unread-hashtb)))) - (cond (show-all - ;; Select all active articles. - (setq articles - (gnus-uncompress-sequence - (nthcdr 2 (gnus-gethash group gnus-active-hashtb))))) - (t - ;; Select unread articles only. - (setq articles gnus-newsgroup-unreads))) - ;; Require confirmation if selecting large newsgroup. - (setq gnus-newsgroup-unselected nil) - (if (not (numberp gnus-large-newsgroup)) - nil - (let ((selected nil) - (number (length articles))) - (if (> number gnus-large-newsgroup) - (progn - (condition-case () - (let ((input - (read-string - (format - "How many articles from %s (default %d): " - gnus-newsgroup-name number)))) - (setq selected - (if (string-equal input "") - number (string-to-int input)))) - (quit - (setq selected 0))) - (cond ((and (> selected 0) - (< selected number)) - ;; Select last N articles. - (setq articles (nthcdr (- number selected) articles))) - ((and (< selected 0) - (< (- 0 selected) number)) - ;; Select first N articles. - (setq selected (- 0 selected)) - (setq articles (copy-sequence articles)) - (setcdr (nthcdr (1- selected) articles) nil)) - ((zerop selected) - (setq articles nil)) - ;; Otherwise select all. - ) - ;; Get unselected unread articles. - (setq gnus-newsgroup-unselected - (gnus-set-difference gnus-newsgroup-unreads articles)) - )) - )) - ;; Get headers list. - (setq gnus-newsgroup-headers (gnus-retrieve-headers articles)) - ;; UNREADS may contain expired articles, so we have to remove - ;; them from the list. - (setq gnus-newsgroup-unreads - (gnus-intersection gnus-newsgroup-unreads - (mapcar - (function - (lambda (header) - (nntp-header-number header))) - gnus-newsgroup-headers))) - ;; Marked article must be a subset of unread articles. - (setq gnus-newsgroup-marked - (gnus-intersection (append gnus-newsgroup-unselected - gnus-newsgroup-unreads) - (cdr - (gnus-gethash group gnus-marked-hashtb)))) - ;; First and last article in this newsgroup. - (setq gnus-newsgroup-begin - (if gnus-newsgroup-headers - (nntp-header-number (car gnus-newsgroup-headers)) - 0 - )) - (setq gnus-newsgroup-end - (if gnus-newsgroup-headers - (nntp-header-number - (gnus-last-element gnus-newsgroup-headers)) - 0 - )) - ;; File name that an article was saved last. - (setq gnus-newsgroup-last-rmail nil) - (setq gnus-newsgroup-last-mail nil) - (setq gnus-newsgroup-last-folder nil) - (setq gnus-newsgroup-last-file nil) - ;; Reset article pointer etc. - (setq gnus-current-article nil) - (setq gnus-current-headers nil) - (setq gnus-current-history nil) - (setq gnus-have-all-headers nil) - (setq gnus-last-article nil) - ;; Clear old hash tables for the variable gnus-newsgroup-headers. - (gnus-clear-hashtables-for-newsgroup-headers) - ;; GROUP is successfully selected. - t - ) - )) - -;; Hacking for making header search much faster. - -(defun gnus-get-header-by-number (number) - "Return a header specified by a NUMBER. -If you update the variable `gnus-newsgroup-headers', you must set the -hash table `gnus-newsgroup-headers-hashtb-by-number' to nil to indicate -rehash is necessary." - (or gnus-newsgroup-headers-hashtb-by-number - (gnus-make-headers-hashtable-by-number)) - (gnus-gethash (int-to-string number) - gnus-newsgroup-headers-hashtb-by-number)) - -(defun gnus-get-header-by-id (id) - "Return a header specified by an ID. -If you update the variable `gnus-newsgroup-headers', you must set the -hash table `gnus-newsgroup-headers-hashtb-by-id' to nil to indicate -rehash is necessary." - (or gnus-newsgroup-headers-hashtb-by-id - (gnus-make-headers-hashtable-by-id)) - (and (stringp id) - (gnus-gethash id gnus-newsgroup-headers-hashtb-by-id))) - -(defun gnus-make-headers-hashtable-by-number () - "Make hashtable for the variable `gnus-newsgroup-headers' by number." - (let ((header nil) - (headers gnus-newsgroup-headers)) - (setq gnus-newsgroup-headers-hashtb-by-number - (gnus-make-hashtable (length headers))) - (while headers - (setq header (car headers)) - (gnus-sethash (int-to-string (nntp-header-number header)) - header gnus-newsgroup-headers-hashtb-by-number) - (setq headers (cdr headers)) - ))) - -(defun gnus-make-headers-hashtable-by-id () - "Make hashtable for the variable `gnus-newsgroup-headers' by id." - (let ((header nil) - (headers gnus-newsgroup-headers)) - (setq gnus-newsgroup-headers-hashtb-by-id - (gnus-make-hashtable (length headers))) - (while headers - (setq header (car headers)) - (gnus-sethash (nntp-header-id header) - header gnus-newsgroup-headers-hashtb-by-id) - (setq headers (cdr headers)) - ))) - -(defun gnus-clear-hashtables-for-newsgroup-headers () - "Clear hash tables created for the variable `gnus-newsgroup-headers'." - (setq gnus-newsgroup-headers-hashtb-by-id nil) - (setq gnus-newsgroup-headers-hashtb-by-number nil)) - -(defun gnus-more-header-backward () - "Find new header backward." - (let ((first - (car (nth 2 (gnus-gethash gnus-newsgroup-name gnus-active-hashtb)))) - (artnum gnus-newsgroup-begin) - (header nil)) - (while (and (not header) - (> artnum first)) - (setq artnum (1- artnum)) - (setq header (car (gnus-retrieve-headers (list artnum))))) - header - )) - -(defun gnus-more-header-forward () - "Find new header forward." - (let ((last - (cdr (nth 2 (gnus-gethash gnus-newsgroup-name gnus-active-hashtb)))) - (artnum gnus-newsgroup-end) - (header nil)) - (while (and (not header) - (< artnum last)) - (setq artnum (1+ artnum)) - (setq header (car (gnus-retrieve-headers (list artnum))))) - header - )) - -(defun gnus-extend-newsgroup (header &optional backward) - "Extend newsgroup selection with HEADER. -Optional argument BACKWARD means extend toward backward." - (if header - (let ((artnum (nntp-header-number header))) - (setq gnus-newsgroup-headers - (if backward - (cons header gnus-newsgroup-headers) - (append gnus-newsgroup-headers (list header)))) - ;; Clear current hash tables for the variable gnus-newsgroup-headers. - (gnus-clear-hashtables-for-newsgroup-headers) - ;; We have to update unreads and unselected, but don't have to - ;; care about gnus-newsgroup-marked. - (if (memq artnum gnus-newsgroup-unselected) - (setq gnus-newsgroup-unreads - (cons artnum gnus-newsgroup-unreads))) - (setq gnus-newsgroup-unselected - (delq artnum gnus-newsgroup-unselected)) - (setq gnus-newsgroup-begin (min gnus-newsgroup-begin artnum)) - (setq gnus-newsgroup-end (max gnus-newsgroup-end artnum)) - ))) - -(defun gnus-mark-article-as-read (article) - "Remember that ARTICLE is marked as read." - ;; Remove from unread and marked list. - (setq gnus-newsgroup-unreads - (delq article gnus-newsgroup-unreads)) - (setq gnus-newsgroup-marked - (delq article gnus-newsgroup-marked))) - -(defun gnus-mark-article-as-unread (article &optional clear-mark) - "Remember that ARTICLE is marked as unread. -Optional argument CLEAR-MARK means ARTICLE should not be remembered -that it was marked as read once." - ;; Add to unread list. - (or (memq article gnus-newsgroup-unreads) - (setq gnus-newsgroup-unreads - (cons article gnus-newsgroup-unreads))) - ;; If CLEAR-MARK is non-nil, the article must be removed from marked - ;; list. Otherwise, it must be added to the list. - (if clear-mark - (setq gnus-newsgroup-marked - (delq article gnus-newsgroup-marked)) - (or (memq article gnus-newsgroup-marked) - (setq gnus-newsgroup-marked - (cons article gnus-newsgroup-marked))))) - -(defun gnus-clear-system () - "Clear all variables and buffer." - ;; Clear GNUS variables. - (let ((variables gnus-variable-list)) - (while variables - (set (car variables) nil) - (setq variables (cdr variables)))) - ;; Clear other internal variables. - (setq gnus-newsrc-hashtb nil) - (setq gnus-marked-hashtb nil) - (setq gnus-killed-hashtb nil) - (setq gnus-active-hashtb nil) - (setq gnus-octive-hashtb nil) - (setq gnus-unread-hashtb nil) - (setq gnus-newsgroup-headers nil) - (setq gnus-newsgroup-headers-hashtb-by-id nil) - (setq gnus-newsgroup-headers-hashtb-by-number nil) - ;; Kill the startup file. - (and gnus-current-startup-file - (get-file-buffer gnus-current-startup-file) - (kill-buffer (get-file-buffer gnus-current-startup-file))) - (setq gnus-current-startup-file nil) - ;; Kill GNUS buffers. - (let ((buffers gnus-buffer-list)) - (while buffers - (if (get-buffer (car buffers)) - (kill-buffer (car buffers))) - (setq buffers (cdr buffers)) - ))) - -(defun gnus-configure-windows (action) - "Configure GNUS windows according to the next ACTION. -The ACTION is either a symbol, such as `summary', or a -configuration list such as `(1 1 2)'. If ACTION is not a list, -configuration list is got from the variable `gnus-window-configuration'." - (let* ((windows - (if (listp action) - action (car (cdr (assq action gnus-window-configuration))))) - (grpwin (get-buffer-window gnus-group-buffer)) - (subwin (get-buffer-window gnus-summary-buffer)) - (artwin (get-buffer-window gnus-article-buffer)) - (winsum nil) - (height nil) - (grpheight 0) - (subheight 0) - (artheight 0) - ;; Make split-window-vertically leave focus in upper window. - (split-window-keep-point t)) - (if (or (null windows) ;No configuration is specified. - (and (eq (null grpwin) - (zerop (nth 0 windows))) - (eq (null subwin) - (zerop (nth 1 windows))) - (eq (null artwin) - (zerop (nth 2 windows))))) - ;; No need to change window configuration. - nil - (select-window (or grpwin subwin artwin (selected-window))) - ;; First of all, compute the height of each window. - (cond (gnus-use-full-window - ;; Take up the entire screen. - (delete-other-windows) - (setq height (window-height (selected-window)))) - (t - (setq height (+ (if grpwin (window-height grpwin) 0) - (if subwin (window-height subwin) 0) - (if artwin (window-height artwin) 0))))) - ;; The Newsgroup buffer exits always. So, use it to extend the - ;; Group window so as to get enough window space. - (switch-to-buffer gnus-group-buffer 'norecord) - (and (get-buffer gnus-summary-buffer) - (delete-windows-on gnus-summary-buffer)) - (and (get-buffer gnus-article-buffer) - (delete-windows-on gnus-article-buffer)) - ;; Compute expected window height. - (setq winsum (apply (function +) windows)) - (if (not (zerop (nth 0 windows))) - (setq grpheight (max window-min-height - (/ (* height (nth 0 windows)) winsum)))) - (if (not (zerop (nth 1 windows))) - (setq subheight (max window-min-height - (/ (* height (nth 1 windows)) winsum)))) - (if (not (zerop (nth 2 windows))) - (setq artheight (max window-min-height - (/ (* height (nth 2 windows)) winsum)))) - (setq height (+ grpheight subheight artheight)) - (enlarge-window (max 0 (- height (window-height (selected-window))))) - ;; Then split the window. - (and (not (zerop artheight)) - (or (not (zerop grpheight)) - (not (zerop subheight))) - (split-window-vertically (+ grpheight subheight))) - (and (not (zerop grpheight)) - (not (zerop subheight)) - (split-window-vertically grpheight)) - ;; Then select buffers in each window. - (and (not (zerop grpheight)) - (progn - (switch-to-buffer gnus-group-buffer 'norecord) - (other-window 1))) - (and (not (zerop subheight)) - (progn - (switch-to-buffer gnus-summary-buffer 'norecord) - (other-window 1))) - (and (not (zerop artheight)) - (progn - ;; If Article buffer does not exist, it will be created - ;; and initialized. - (gnus-article-setup-buffer) - (switch-to-buffer gnus-article-buffer 'norecord))) - ) - )) - -(defun gnus-find-header-by-number (headers number) - "Return a header which is a element of HEADERS and has NUMBER." - (let ((found nil)) - (while (and headers (not found)) - ;; We cannot use `=' to accept non-numeric NUMBER. - (if (eq number (nntp-header-number (car headers))) - (setq found (car headers))) - (setq headers (cdr headers))) - found - )) - -(defun gnus-find-header-by-id (headers id) - "Return a header which is a element of HEADERS and has Message-ID." - (let ((found nil)) - (while (and headers (not found)) - (if (string-equal id (nntp-header-id (car headers))) - (setq found (car headers))) - (setq headers (cdr headers))) - found - )) - -(defun gnus-version () - "Version numbers of this version of GNUS." - (interactive) - (cond ((and (boundp 'mhspool-version) (boundp 'nnspool-version)) - (message "%s; %s; %s; %s" - gnus-version nntp-version nnspool-version mhspool-version)) - ((boundp 'mhspool-version) - (message "%s; %s; %s" - gnus-version nntp-version mhspool-version)) - ((boundp 'nnspool-version) - (message "%s; %s; %s" - gnus-version nntp-version nnspool-version)) - (t - (message "%s; %s" gnus-version nntp-version)))) - -(defun gnus-info-find-node () - "Find Info documentation of GNUS." - (interactive) - (require 'info) - ;; Enlarge info window if needed. - (cond ((eq major-mode 'gnus-group-mode) - (gnus-configure-windows '(1 0 0)) ;Take all windows. - (pop-to-buffer gnus-group-buffer)) - ((eq major-mode 'gnus-summary-mode) - (gnus-configure-windows '(0 1 0)) ;Take all windows. - (pop-to-buffer gnus-summary-buffer))) - (Info-goto-node (car (cdr (assq major-mode gnus-info-nodes))))) - -(defun gnus-overload-functions (&optional overloads) - "Overload functions specified by optional argument OVERLOADS. -If nothing is specified, use the variable `gnus-overload-functions'." - (let ((defs nil) - (overloads (or overloads gnus-overload-functions))) - (while overloads - (setq defs (car overloads)) - (setq overloads (cdr overloads)) - ;; Load file before overloading function if necessary. Make - ;; sure we cannot use `require' always. - (and (not (fboundp (car defs))) - (car (cdr (cdr defs))) - (load (car (cdr (cdr defs))) nil 'nomessage)) - (fset (car defs) (car (cdr defs))) - ))) - -(defun gnus-make-threads (newsgroup-headers) - "Make conversation threads tree from NEWSGROUP-HEADERS." - (let ((headers newsgroup-headers) - (refer nil) - (h nil) - (d nil) - (roots nil) - (dependencies nil)) - ;; Make message dependency alist. - (while headers - (setq h (car headers)) - (setq headers (cdr headers)) - ;; Ignore invalid headers. - (if (vectorp h) ;Depends on nntp.el. - (progn - ;; Ignore broken references, e.g "<123@a.b.c". - (setq refer (nntp-header-references h)) - (setq d (and refer - (string-match "\\(<[^<>]+>\\)[^>]*$" refer) -;; (gnus-find-header-by-id -;; newsgroup-headers -;; (substring refer (match-beginning 1) (match-end 1))) - ;; In fact if the variable newsgroup-headers - ;; is not 'equal' to the variable - ;; gnus-newsgroup-headers, the following - ;; function call may return bogus value. - (gnus-get-header-by-id - (substring refer (match-beginning 1) (match-end 1))) - )) - ;; Check subject equality. - (or gnus-thread-ignore-subject - (null d) - (string-equal (gnus-simplify-subject - (nntp-header-subject h) 're) - (gnus-simplify-subject - (nntp-header-subject d) 're)) - ;; H should be a thread root. - (setq d nil)) - ;; H depends on D. - (setq dependencies - (cons (cons h d) dependencies)) - ;; H is a thread root. - (if (null d) - (setq roots (cons h roots))) - )) - ) - ;; Make complete threads from the roots. - ;; Note: dependencies are in reverse order, but - ;; gnus-make-threads-1 processes it in reverse order again. So, - ;; we don't have to worry about it. - (mapcar - (function - (lambda (root) - (gnus-make-threads-1 root dependencies))) (nreverse roots)) - )) - -(defun gnus-make-threads-1 (parent dependencies) - (let ((children nil) - (d nil) - (depends dependencies)) - ;; Find children. - (while depends - (setq d (car depends)) - (setq depends (cdr depends)) - (and (cdr d) - (eq (nntp-header-id parent) (nntp-header-id (cdr d))) - (setq children (cons (car d) children)))) - ;; Go down. - (cons parent - (mapcar - (function - (lambda (child) - (gnus-make-threads-1 child dependencies))) children)) - )) - -(defun gnus-narrow-to-page (&optional arg) - "Make text outside current page invisible except for page delimiter. -A numeric arg specifies to move forward or backward by that many pages, -thus showing a page other than the one point was originally in." - (interactive "P") - (setq arg (if arg (prefix-numeric-value arg) 0)) - (save-excursion - (forward-page -1) ;Beginning of current page. - (widen) - (if (> arg 0) - (forward-page arg) - (if (< arg 0) - (forward-page (1- arg)))) - ;; Find the end of the page. - (forward-page) - ;; If we stopped due to end of buffer, stay there. - ;; If we stopped after a page delimiter, put end of restriction - ;; at the beginning of that line. - ;; These are commented out. - ;; (if (save-excursion (beginning-of-line) - ;; (looking-at page-delimiter)) - ;; (beginning-of-line)) - (narrow-to-region (point) - (progn - ;; Find the top of the page. - (forward-page -1) - ;; If we found beginning of buffer, stay there. - ;; If extra text follows page delimiter on same line, - ;; include it. - ;; Otherwise, show text starting with following line. - (if (and (eolp) (not (bobp))) - (forward-line 1)) - (point))) - )) - -;; Create hash table for alist, such as gnus-newsrc-assoc, -;; gnus-killed-assoc, and gnus-marked-assoc. - -(defun gnus-make-hashtable-from-alist (alist &optional hashsize) - "Return hash table for ALIST. -Optional argument HASHSIZE specifies the hashtable size. -Hash key is a car of alist element, which must be a string." - (let ((hashtb (gnus-make-hashtable (or hashsize (length alist))))) - (while alist - (gnus-sethash (car (car alist)) ;Newsgroup name - (car alist) ;Alist element - hashtb) - (setq alist (cdr alist))) - hashtb - )) - -(defun gnus-last-element (list) - "Return last element of LIST." - (let ((last nil)) - (while list - (if (null (cdr list)) - (setq last (car list))) - (setq list (cdr list))) - last - )) - -(defun gnus-set-difference (list1 list2) - "Return a list of elements of LIST1 that do not appear in LIST2." - (let ((list1 (copy-sequence list1))) - (while list2 - (setq list1 (delq (car list2) list1)) - (setq list2 (cdr list2))) - list1 - )) - -(defun gnus-intersection (list1 list2) - "Return a list of elements that appear in both LIST1 and LIST2." - (let ((result nil)) - (while list2 - (if (memq (car list2) list1) - (setq result (cons (car list2) result))) - (setq list2 (cdr list2))) - result - )) - - -;;; -;;; Get information about active articles, already read articles, and -;;; still unread articles. -;;; - -;; GNUS internal format of gnus-newsrc-assoc and gnus-killed-assoc: -;; (("general" t (1 . 1)) -;; ("misc" t (1 . 10) (12 . 15)) -;; ("test" nil (1 . 99)) ...) -;; GNUS internal format of gnus-marked-assoc: -;; (("general" 1 2 3) -;; ("misc" 2) ...) -;; GNUS internal format of gnus-active-hashtb: -;; (("general" t (1 . 1)) -;; ("misc" t (1 . 10)) -;; ("test" nil (1 . 99)) ...) -;; GNUS internal format of gnus-unread-hashtb: -;; (("general" 1 (1 . 1)) -;; ("misc" 14 (1 . 10) (12 . 15)) -;; ("test" 99 (1 . 99)) ...) - -(defun gnus-setup-news (&optional rawfile) - "Setup news information. -If optional argument RAWFILE is non-nil, force to read raw startup file." - (let ((init (not (and gnus-newsrc-assoc - gnus-active-hashtb - gnus-unread-hashtb - (not rawfile) - )))) - ;; We have to clear some variables to re-initialize news info. - (if init - (setq gnus-newsrc-assoc nil - gnus-active-hashtb nil - gnus-unread-hashtb nil)) - (gnus-read-active-file) - ;; Initialize only once. - (if init - (progn - ;; Get distributions only once. - (gnus-read-distributions-file) - ;; newsrc file must be read after reading active file since - ;; its size is used to guess the size of gnus-newsrc-hashtb. - (gnus-read-newsrc-file rawfile) - )) - (gnus-expire-marked-articles) - (gnus-get-unread-articles) - - ;; newsgroups description - (if gnus-newsgroups-display - (if (not gnus-newsgroups-alist) - ;; Get newsgroups file only once. - (gnus-newsgroups-retrieve-description))) - - (setq gnus-newsgroups-hashtb (gnus-make-hashtable-from-alist gnus-newsgroups-alist)) - - ;; Check new newsgroups and subscribe them. - (if init - (let ((new-newsgroups (gnus-find-new-newsgroups))) - (while new-newsgroups - (funcall gnus-subscribe-newsgroup-method (car new-newsgroups)) - (setq new-newsgroups (cdr new-newsgroups)) - ))) - )) - -(defun gnus-add-newsgroup (newsgroup) - "Subscribe new NEWSGROUP safely and put it at top." - (and (null (gnus-gethash newsgroup gnus-newsrc-hashtb)) ;Really new? - (gnus-gethash newsgroup gnus-active-hashtb) ;Really exist? - (gnus-insert-newsgroup (or (gnus-gethash newsgroup gnus-killed-hashtb) - (list newsgroup t)) - (car (car gnus-newsrc-assoc))))) - -(defun gnus-find-new-newsgroups () - "Looking for new newsgroups and return names. -`-n' option of options line in `.newsrc' file is recognized." - (let ((group nil) - (new-newsgroups nil)) - (mapatoms - (function - (lambda (sym) - (setq group (symbol-name sym)) - ;; Taking account of `-n' option. - (and (or (null gnus-newsrc-options-n-no) - (not (string-match gnus-newsrc-options-n-no group)) - (and gnus-newsrc-options-n-yes - (string-match gnus-newsrc-options-n-yes group))) - (null (gnus-gethash group gnus-killed-hashtb)) ;Ignore killed. - (null (gnus-gethash group gnus-newsrc-hashtb)) ;Really new. - ;; Find new newsgroup. - (setq new-newsgroups - (cons group new-newsgroups))) - )) - gnus-active-hashtb) - ;; Return new newsgroups. - new-newsgroups - )) - -(defun gnus-kill-newsgroup (group) - "Kill GROUP from `gnus-newsrc-assoc', `.newsrc' and `gnus-unread-hashtb'." - (let ((info (gnus-gethash group gnus-newsrc-hashtb))) - (if (null info) - nil - ;; Delete from gnus-newsrc-assoc and gnus-newsrc-hashtb. - (setq gnus-newsrc-assoc (delq info gnus-newsrc-assoc)) - (gnus-sethash group nil gnus-newsrc-hashtb) - ;; Add to gnus-killed-assoc and gnus-killed-hashtb. - (setq gnus-killed-assoc - (cons info - (delq (gnus-gethash group gnus-killed-hashtb) - gnus-killed-assoc))) - (gnus-sethash group info gnus-killed-hashtb) - ;; Clear unread hashtable. - ;; Thanks cwitty@csli.Stanford.EDU (Carl Witty). - (gnus-sethash group nil gnus-unread-hashtb) - ;; Then delete from .newsrc - (gnus-update-newsrc-buffer group 'delete) - ;; Return the deleted newsrc entry. - info - ))) - -(defun gnus-insert-newsgroup (info &optional next) - "Insert newsrc INFO entry before NEXT. -If optional argument NEXT is nil, appended to the last." - (if (null info) - (error "Invalid argument: %s" info)) - (let* ((group (car info)) ;Newsgroup name. - (range - (gnus-difference-of-range - (nth 2 (gnus-gethash group gnus-active-hashtb)) (nthcdr 2 info)))) - ;; Check duplication. - (if (gnus-gethash group gnus-newsrc-hashtb) - (error "Duplicated: %s" group)) - ;; Insert to gnus-newsrc-assoc and gnus-newsrc-hashtb. - (if (string-equal next (car (car gnus-newsrc-assoc))) - (setq gnus-newsrc-assoc - (cons info gnus-newsrc-assoc)) - (let ((found nil) - (rest (cdr gnus-newsrc-assoc)) - (tail gnus-newsrc-assoc)) - ;; Seach insertion point. - (while (and (not found) rest) - (if (string-equal next (car (car rest))) - (setq found t) - (setq rest (cdr rest)) - (setq tail (cdr tail)) - )) - ;; Find it. - (if (consp tail) - (setcdr tail (cons info rest)) - ;; gnus-newsrc-assoc must be nil. - (setq gnus-newsrc-assoc - (append gnus-newsrc-assoc (cons info rest)))) - )) - (gnus-sethash group info gnus-newsrc-hashtb) - ;; Delete from gnus-killed-assoc and gnus-killed-hashtb. - (setq gnus-killed-assoc - (delq (gnus-gethash group gnus-killed-hashtb) gnus-killed-assoc)) - (gnus-sethash group nil gnus-killed-hashtb) - ;; Then insert to .newsrc. - (gnus-update-newsrc-buffer group nil next) - ;; Add to gnus-unread-hashtb. - (gnus-sethash group - (cons group ;Newsgroup name. - (cons (gnus-number-of-articles range) range)) - gnus-unread-hashtb) - )) - -(defun gnus-check-killed-newsgroups () - "Update `gnus-killed-assoc' based on `gnus-newsrc-assoc'. -Update `gnus-killed-hashtb' also." - (let ((group nil) - (new-killed nil) - (old-killed gnus-killed-assoc)) - (while old-killed - (setq group (car (car old-killed))) - (and (or (null gnus-newsrc-options-n-no) - (not (string-match gnus-newsrc-options-n-no group)) - (and gnus-newsrc-options-n-yes - (string-match gnus-newsrc-options-n-yes group))) - (null (gnus-gethash group gnus-newsrc-hashtb)) ;No duplication. - ;; Subscribed in options line and not in gnus-newsrc-assoc. - (setq new-killed - (cons (car old-killed) new-killed))) - (setq old-killed (cdr old-killed)) - ) - (setq gnus-killed-assoc (nreverse new-killed)) - (setq gnus-killed-hashtb - (gnus-make-hashtable-from-alist gnus-killed-assoc)) - )) - -(defun gnus-check-bogus-newsgroups (&optional confirm) - "Delete bogus newsgroups. -If optional argument CONFIRM is non-nil, confirm deletion of newsgroups." - (let ((group nil) ;Newsgroup name temporary used. - (old-newsrc gnus-newsrc-assoc) - (new-newsrc nil) - (bogus nil) ;List of bogus newsgroups. - (old-killed gnus-killed-assoc) - (new-killed nil) - (old-marked gnus-marked-assoc) - (new-marked nil)) - (message "Checking bogus newsgroups...") - ;; Update gnus-newsrc-assoc and gnus-newsrc-hashtb. - (while old-newsrc - (setq group (car (car old-newsrc))) - (if (or (gnus-gethash group gnus-active-hashtb) - (and confirm - (not (y-or-n-p - (format "Delete bogus newsgroup: %s " group))))) - ;; Active newsgroup. - (setq new-newsrc (cons (car old-newsrc) new-newsrc)) - ;; Found a bogus newsgroup. - (setq bogus (cons group bogus))) - (setq old-newsrc (cdr old-newsrc)) - ) - (setq gnus-newsrc-assoc (nreverse new-newsrc)) - (setq gnus-newsrc-hashtb - (gnus-make-hashtable-from-alist gnus-newsrc-assoc)) - ;; Update gnus-killed-assoc and gnus-killed-hashtb. - ;; The killed newsgroups are deleted without any confirmations. - (while old-killed - (setq group (car (car old-killed))) - (and (gnus-gethash group gnus-active-hashtb) - (null (gnus-gethash group gnus-newsrc-hashtb)) - ;; Active and really killed newsgroup. - (setq new-killed (cons (car old-killed) new-killed))) - (setq old-killed (cdr old-killed)) - ) - (setq gnus-killed-assoc (nreverse new-killed)) - (setq gnus-killed-hashtb - (gnus-make-hashtable-from-alist gnus-killed-assoc)) - ;; Remove BOGUS from .newsrc file. - (while bogus - (gnus-update-newsrc-buffer (car bogus) 'delete) - (setq bogus (cdr bogus))) - ;; Update gnus-marked-assoc and gnus-marked-hashtb. - (while old-marked - (setq group (car (car old-marked))) - (if (and (cdr (car old-marked)) ;Non-empty? - (gnus-gethash group gnus-newsrc-hashtb)) ;Not bogus? - (setq new-marked (cons (car old-marked) new-marked))) - (setq old-marked (cdr old-marked))) - (setq gnus-marked-assoc new-marked) - (setq gnus-marked-hashtb - (gnus-make-hashtable-from-alist gnus-marked-assoc)) - (message "Checking bogus newsgroups...done") - )) - -(defun gnus-get-unread-articles () - "Compute diffs between active and read articles." - (let ((read gnus-newsrc-assoc) - (group-info nil) - (group-name nil) - (active nil) - (range nil)) - (message "Checking new news...") - (or gnus-unread-hashtb - (setq gnus-unread-hashtb - (gnus-make-hashtable (length gnus-active-hashtb)))) - (while read - (setq group-info (car read)) ;About one newsgroup - (setq group-name (car group-info)) - (setq active (nth 2 (gnus-gethash group-name gnus-active-hashtb))) - (if (and gnus-octive-hashtb - ;; Is nothing changed? - (equal active - (nth 2 (gnus-gethash group-name gnus-octive-hashtb))) - ;; Is this newsgroup in the unread hash table? - (gnus-gethash group-name gnus-unread-hashtb) - ) - nil ;Nothing to do. - (setq range (gnus-difference-of-range active (nthcdr 2 group-info))) - (gnus-sethash group-name - (cons group-name ;Group name - (cons (gnus-number-of-articles range) - range)) ;Range of unread articles - gnus-unread-hashtb) - ) - (setq read (cdr read)) - ) - (message "Checking new news...done") - )) - -(defun gnus-expire-marked-articles () - "Check expired article which is marked as unread." - (let ((marked-assoc gnus-marked-assoc) - (updated-assoc nil) - (marked nil) ;Current marked info. - (articles nil) ;List of marked articles. - (updated nil) ;List of real marked. - (begin nil)) - (while marked-assoc - (setq marked (car marked-assoc)) - (setq articles (cdr marked)) - (setq updated nil) - (setq begin - (car (nth 2 (gnus-gethash (car marked) gnus-active-hashtb)))) - (while (and begin articles) - (if (>= (car articles) begin) - ;; This article is still active. - (setq updated (cons (car articles) updated))) - (setq articles (cdr articles))) - (if updated - (setq updated-assoc - (cons (cons (car marked) updated) updated-assoc))) - (setq marked-assoc (cdr marked-assoc))) - (setq gnus-marked-assoc updated-assoc) - (setq gnus-marked-hashtb - (gnus-make-hashtable-from-alist gnus-marked-assoc)) - )) - -(defun gnus-mark-as-read-by-xref - (group headers unreads &optional subscribed-only) - "Mark articles as read using cross references and return updated newsgroups. -Arguments are GROUP, HEADERS, UNREADS, and optional SUBSCRIBED-ONLY." - (let ((xref-list nil) - (header nil) - (xrefs nil) ;One Xref: field info. - (xref nil) ;(NEWSGROUP . ARTICLE) - (gname nil) ;Newsgroup name - (article nil)) ;Article number - (while headers - (setq header (car headers)) - (if (memq (nntp-header-number header) unreads) - ;; This article is not yet marked as read. - nil - (setq xrefs (gnus-parse-xref-field (nntp-header-xref header))) - ;; For each cross reference info. in one Xref: field. - (while xrefs - (setq xref (car xrefs)) - (setq gname (car xref)) ;Newsgroup name - (setq article (cdr xref)) ;Article number - (or (string-equal group gname) ;Ignore current newsgroup. - ;; Ignore unsubscribed newsgroup if requested. - (and subscribed-only - (not (nth 1 (gnus-gethash gname gnus-newsrc-hashtb)))) - ;; Ignore article marked as unread. - (memq article (cdr (gnus-gethash gname gnus-marked-hashtb))) - (let ((group-xref (assoc gname xref-list))) - (if group-xref - (if (memq article (cdr group-xref)) - nil ;Alread marked. - (setcdr group-xref (cons article (cdr group-xref)))) - ;; Create new assoc entry for GROUP. - (setq xref-list (cons (list gname article) xref-list))) - )) - (setq xrefs (cdr xrefs)) - )) - (setq headers (cdr headers))) - ;; Mark cross referenced articles as read. - (gnus-mark-xrefed-as-read xref-list) - ;;(message "%s %s" (prin1-to-string unreads) (prin1-to-string xref-list)) - ;; Return list of updated group name. - (mapcar (function car) xref-list) - )) - -(defun gnus-parse-xref-field (xref-value) - "Parse Xref: field value, and return list of `(group . article-id)'." - (let ((xref-list nil) - (xref-value (or xref-value ""))) - ;; Remove server host name. - (if (string-match "^[ \t]*[^ \t,]+[ \t,]+\\(.*\\)$" xref-value) - (setq xref-value (substring xref-value (match-beginning 1))) - (setq xref-value nil)) - ;; Process each xref info. - (while xref-value - (if (string-match - "^[ \t,]*\\([^ \t,]+\\):\\([0-9]+\\)[^0-9]*" xref-value) - (progn - (setq xref-list - (cons - (cons - ;; Group name - (substring xref-value (match-beginning 1) (match-end 1)) - ;; Article-ID - (string-to-int - (substring xref-value (match-beginning 2) (match-end 2)))) - xref-list)) - (setq xref-value (substring xref-value (match-end 2)))) - (setq xref-value nil))) - ;; Return alist. - xref-list - )) - -(defun gnus-mark-xrefed-as-read (xrefs) - "Update unread article information using XREFS alist." - (let ((group nil) - (idlist nil) - (unread nil)) - (while xrefs - (setq group (car (car xrefs))) - (setq idlist (cdr (car xrefs))) - (setq unread (gnus-uncompress-sequence - (nthcdr 2 (gnus-gethash group gnus-unread-hashtb)))) - (while idlist - (setq unread (delq (car idlist) unread)) - (setq idlist (cdr idlist))) - (gnus-update-unread-articles group unread 'ignore) - (setq xrefs (cdr xrefs)) - ))) - -(defun gnus-update-unread-articles (group unread-list marked-list) - "Update unread articles of GROUP using UNREAD-LIST and MARKED-LIST." - (let ((active (nth 2 (gnus-gethash group gnus-active-hashtb))) - (unread (gnus-gethash group gnus-unread-hashtb))) - (if (or (null active) (null unread)) - ;; Ignore unknown newsgroup. - nil - ;; Update gnus-unread-hashtb. - (if unread-list - (setcdr (cdr unread) - (gnus-compress-sequence unread-list)) - ;; All of the articles are read. - (setcdr (cdr unread) '((0 . 0)))) - ;; Number of unread articles. - (setcar (cdr unread) - (gnus-number-of-articles (nthcdr 2 unread))) - ;; Update gnus-newsrc-assoc. - (if (> (car active) 0) - ;; Articles from 1 to N are not active. - (setq active (cons 1 (cdr active)))) - (setcdr (cdr (gnus-gethash group gnus-newsrc-hashtb)) - (gnus-difference-of-range active (nthcdr 2 unread))) - ;; Update .newsrc buffer. - (gnus-update-newsrc-buffer group) - ;; Update gnus-marked-assoc. - (if (listp marked-list) ;Includes NIL. - (let ((marked (gnus-gethash group gnus-marked-hashtb))) - (cond (marked ;There is an entry. - (setcdr marked marked-list)) - (marked-list ;Non-NIL. - (let ((info (cons group marked-list))) - ;; hashtb must share the same cons cell. - (setq gnus-marked-assoc - (cons info gnus-marked-assoc)) - (gnus-sethash group info gnus-marked-hashtb) - )) - ))) - ))) - -(defun gnus-read-active-file () - "Get active file from NNTP server." - ;; Make sure a connection to NNTP server is alive. - (gnus-start-news-server) - (message "Reading active file...") - (if (gnus-request-list) ;Get active file from server - (save-excursion - (set-buffer nntp-server-buffer) - (gnus-active-to-gnus-format) - (message "Reading active file...done")) - (error "Cannot read active file from NNTP server."))) - -(defun gnus-active-to-gnus-format () - "Convert active file format to internal format. -Lines matching `gnus-ignored-newsgroups' are ignored." - ;; Delete unnecessary lines. - (goto-char (point-min)) - ;;(delete-matching-lines "^to\\..*$") - (delete-matching-lines gnus-ignored-newsgroups) - ;; Save OLD active info. - (setq gnus-octive-hashtb gnus-active-hashtb) - ;; Make large enough hash table. - (setq gnus-active-hashtb - (gnus-make-hashtable (count-lines (point-min) (point-max)))) - ;; Store active file in hashtable. - (goto-char (point-min)) - (while - (re-search-forward - "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([ymn]\\).*$" - nil t) - (gnus-sethash - (buffer-substring (match-beginning 1) (match-end 1)) - (list (buffer-substring (match-beginning 1) (match-end 1)) - (string-equal - "y" (buffer-substring (match-beginning 4) (match-end 4))) - (cons (string-to-int - (buffer-substring (match-beginning 3) (match-end 3))) - (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))))) - gnus-active-hashtb) - )) - -(defun gnus-read-newsrc-file (&optional rawfile) - "Read startup FILE. -If optional argument RAWFILE is non-nil, the raw startup file is read." - (setq gnus-current-startup-file (gnus-make-newsrc-file gnus-startup-file)) - ;; Reset variables which may be included in the quick startup file. - (let ((variables gnus-variable-list)) - (while variables - (set (car variables) nil) - (setq variables (cdr variables)))) - (let* ((newsrc-file gnus-current-startup-file) - (quick-file (concat newsrc-file ".el")) - (quick-loaded nil)) - (save-excursion - ;; Prepare .newsrc buffer. - (set-buffer (find-file-noselect newsrc-file)) - ;; It is not so good idea turning off undo. - ;;(buffer-flush-undo (current-buffer)) - ;; Load quick .newsrc to restore gnus-marked-assoc and - ;; gnus-killed-assoc even if gnus-newsrc-assoc is out of date. - (condition-case nil - (progn - (setq quick-loaded (load quick-file t t t)) - ;; Recreate hashtables. - (setq gnus-killed-hashtb - (gnus-make-hashtable-from-alist gnus-killed-assoc)) - (setq gnus-marked-hashtb - (gnus-make-hashtable-from-alist gnus-marked-assoc)) - ) - (error nil)) - (cond ((and (not rawfile) ;Not forced to read the raw file. - ;; .newsrc.el is newer than .newsrc. - ;; Do it this way in case timestamps are identical - ;; (on fast machines/disks). - (not (file-newer-than-file-p newsrc-file quick-file)) - quick-loaded - gnus-newsrc-assoc ;Really loaded? - ) - ;; We don't have to read the raw startup file. - ;; gnus-newsrc-assoc may be defined in the quick startup file. - ;; So, we have to define the hashtable here. - (setq gnus-newsrc-hashtb - (gnus-make-hashtable-from-alist gnus-newsrc-assoc))) - (t - ;; Since .newsrc file is newer than quick file, read it. - (message "Reading %s..." newsrc-file) - (gnus-newsrc-to-gnus-format) - (gnus-check-killed-newsgroups) - (message "Reading %s...done" newsrc-file))) - ))) - -(defun gnus-make-newsrc-file (file) - "Make server dependent file name by catenating FILE and server host name." - (let* ((file (expand-file-name file nil)) - (real-file (concat file "-" gnus-nntp-server))) - (if (file-exists-p real-file) - real-file file) - )) - -(defun gnus-newsrc-to-gnus-format () - "Parse current buffer as `.newsrc' file." - (let ((newsgroup nil) - (subscribe nil) - (ranges nil) - (subrange nil) - (read-list nil)) - ;; We have to re-initialize these variable (except for - ;; gnus-marked-assoc and gnus-killed-assoc) because quick startup - ;; file may contain bogus values. - (setq gnus-newsrc-options nil) - (setq gnus-newsrc-options-n-yes nil) - (setq gnus-newsrc-options-n-no nil) - (setq gnus-newsrc-assoc nil) - ;; Make large enough hash table. - (setq gnus-newsrc-hashtb - (gnus-make-hashtable - (max (length gnus-active-hashtb) - (count-lines (point-min) (point-max))))) - ;; Save options line to variable. - ;; Lines beginning with white spaces are treated as continuation - ;; line. Refer man page of newsrc(5). - (goto-char (point-min)) - (if (re-search-forward - "^[ \t]*options[ \t]*\\(.*\\(\n[ \t]+.*\\)*\\)[ \t]*$" nil t) - (progn - ;; Save entire options line. - (setq gnus-newsrc-options - (buffer-substring (match-beginning 1) (match-end 1))) - ;; Compile "-n" option. - (if (string-match "\\(^\\|[ \t\n]\\)-n" gnus-newsrc-options) - (let ((yes-and-no - (gnus-parse-n-options - (substring gnus-newsrc-options (match-end 0))))) - (setq gnus-newsrc-options-n-yes (car yes-and-no)) - (setq gnus-newsrc-options-n-no (cdr yes-and-no)) - )) - )) - ;; Parse body of .newsrc file - ;; Options line continuation lines must be also considered here. - ;; Before supporting continuation lines, " newsgroup ! 1-5" was - ;; okay, but now it is invalid. It should be "newsgroup! 1-5". - (goto-char (point-min)) - ;; We used this regexp, but it caused overflows. - ;; "^\\([^:! \t\n]+\\)\\([:!]\\)[ \t]*\\(.*\\)$" - ;; Suggested by composer@bucsf.bu.edu (Jeff Kellem) - ;; but no longer viable because of extensive backtracking in Emacs 19: - ;; "^\\([^:! \t\n]+\\)\\([:!]\\)[ \t]*\\(\\(...\\)*.*\\)$" - ;; but, the following causes trouble on some case: - ;; "^\\([^:! \t\n]+\\)\\([:!]\\)[ \t]*\\(\\|[^ \t\n].*\\)$" - ;; So now we don't try to match the tail of the line at all. - ;; It's just as easy to extract it later. - (while (re-search-forward "^\\([^:! \t\n]+\\)\\([:!]\\)" - nil t) - (setq newsgroup (buffer-substring (match-beginning 1) (match-end 1))) - ;; Check duplications of newsgroups. - ;; Note: Checking the duplications takes very long time. - (if (gnus-gethash newsgroup gnus-newsrc-hashtb) - (message "Ignore duplicated newsgroup: %s" newsgroup) - (setq subscribe - (string-equal - ":" (buffer-substring (match-beginning 2) (match-end 2)))) - (skip-chars-forward " \t") - (setq ranges (buffer-substring (point) (save-excursion - (end-of-line) (point)))) - (setq read-list nil) - (while (string-match "^[, \t]*\\([0-9-]+\\)" ranges) - (setq subrange (substring ranges (match-beginning 1) (match-end 1))) - (setq ranges (substring ranges (match-end 1))) - (cond ((string-match "^\\([0-9]+\\)-\\([0-9]+\\)$" subrange) - (setq read-list - (cons - (cons (string-to-int - (substring subrange - (match-beginning 1) (match-end 1))) - (string-to-int - (substring subrange - (match-beginning 2) (match-end 2)))) - read-list))) - ((string-match "^[0-9]+$" subrange) - (setq read-list - (cons (cons (string-to-int subrange) - (string-to-int subrange)) - read-list))) - (t - (ding) (message "Ignoring bogus lines of %s" newsgroup) - (sit-for 0)) - )) - (setq gnus-newsrc-assoc - (cons (cons newsgroup (cons subscribe (nreverse read-list))) - gnus-newsrc-assoc)) - ;; Update gnus-newsrc-hashtb one by one. - (gnus-sethash newsgroup (car gnus-newsrc-assoc) gnus-newsrc-hashtb) - )) - (setq gnus-newsrc-assoc (nreverse gnus-newsrc-assoc)) - )) - -(defun gnus-parse-n-options (options) - "Parse -n NEWSGROUPS options and return a cons of YES and NO regexps." - (let ((yes nil) - (no nil) - (yes-or-no nil) ;`!' or not. - (newsgroup nil)) - ;; Parse each newsgroup description such as "comp.all". Commas - ;; and white spaces can be a newsgroup separator. - (while - (string-match "^[ \t\n,]*\\(!?\\)\\([^- \t\n,][^ \t\n,]*\\)" options) - (setq yes-or-no - (substring options (match-beginning 1) (match-end 1))) - (setq newsgroup - (regexp-quote - (substring options - (match-beginning 2) (match-end 2)))) - (setq options (substring options (match-end 2))) - ;; Rewrite "all" to ".+" not ".*". ".+" requires at least one - ;; character. - (while (string-match "\\(^\\|\\\\[.]\\)all\\(\\\\[.]\\|$\\)" newsgroup) - (setq newsgroup - (concat (substring newsgroup 0 (match-end 1)) - ".+" - (substring newsgroup (match-beginning 2))))) - ;; It is yes or no. - (cond ((string-equal yes-or-no "!") - (setq no (cons newsgroup no))) - ((string-equal newsgroup ".+")) ;Ignore `all'. - (t - (setq yes (cons newsgroup yes)))) - ) - ;; Make a cons of regexps from parsing result. - ;; We have to append \(\.\|$\) to prevent matching substring of - ;; newsgroup. For example, "jp.net" should not match with - ;; "jp.network". - ;; Fixes for large regexp problems are from yonezu@nak.math.keio.ac.jp. - (cons (if yes - (concat "^\\(" - (apply (function concat) - (mapcar - (function - (lambda (newsgroup) - (concat newsgroup "\\|"))) - (cdr yes))) - (car yes) "\\)\\(\\.\\|$\\)")) - (if no - (concat "^\\(" - (apply (function concat) - (mapcar - (function - (lambda (newsgroup) - (concat newsgroup "\\|"))) - (cdr no))) - (car no) "\\)\\(\\.\\|$\\)"))) - )) - -(defun gnus-save-newsrc-file () - "Save current status in the `.newsrc' file." - ;; Note: We cannot save .newsrc file if all newsgroups are removed - ;; from the variable gnus-newsrc-assoc. - (and (or gnus-newsrc-assoc gnus-killed-assoc) - gnus-current-startup-file - (save-excursion - ;; A buffer containing .newsrc file may be deleted. - (set-buffer (find-file-noselect gnus-current-startup-file)) - (if (not (buffer-modified-p)) - (message "(No changes need to be saved)") - (message "Saving %s..." gnus-current-startup-file) - (let ((make-backup-files t) - (version-control nil) - (require-final-newline t)) ;Don't ask even if requested. - ;; Make backup file of master newsrc. - ;; You can stop or change version control of backup file. - ;; Suggested by jason@violet.berkeley.edu. - (run-hooks 'gnus-save-newsrc-hook) - (save-buffer)) - ;; Quickly loadable .newsrc. - (set-buffer (get-buffer-create " *GNUS-newsrc*")) - (buffer-flush-undo (current-buffer)) - (erase-buffer) - (gnus-gnus-to-quick-newsrc-format) - (let ((make-backup-files nil) - (version-control nil) - (require-final-newline t)) ;Don't ask even if requested. - (write-file (concat gnus-current-startup-file ".el"))) - (kill-buffer (current-buffer)) - (message "Saving %s...done" gnus-current-startup-file) - )) - )) - -(defun gnus-update-newsrc-buffer (group &optional delete next) - "Incrementally update `.newsrc' buffer about GROUP. -If optional 1st argument DELETE is non-nil, delete the group. -If optional 2nd argument NEXT is non-nil, inserted before it." - (save-excursion - ;; Taking account of the killed startup file. - ;; Suggested by tale@pawl.rpi.edu. - (set-buffer (or (get-file-buffer gnus-current-startup-file) - (find-file-noselect gnus-current-startup-file))) - ;; Options line continuation lines must be also considered here. - ;; Before supporting continuation lines, " newsgroup ! 1-5" was - ;; okay, but now it is invalid. It should be "newsgroup! 1-5". - (let ((deleted nil) - (case-fold-search nil) ;Should NOT ignore case. - (buffer-read-only nil)) ;May be not modifiable. - ;; Delete ALL entries which match for GROUP. - (goto-char (point-min)) - (while (re-search-forward - (concat "^" (regexp-quote group) "[:!]") nil t) - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point))) - (setq deleted t) ;Old entry is deleted. - ) - (if delete - nil - ;; Insert group entry. - (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb))) - (if (null newsrc) - nil - ;; Find insertion point. - (cond (deleted nil) ;Insert here. - ((and (stringp next) - (progn - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote next) "[:!]") nil t))) - (beginning-of-line)) - (t - (goto-char (point-max)) - (or (bolp) - (insert "\n")))) - ;; Insert after options line. - (if (looking-at "^[ \t]*options\\([ \t]\\|$\\)") - (progn - (forward-line 1) - ;; Skip continuation lines. - (while (and (not (eobp)) - (looking-at "^[ \t]+")) - (forward-line 1)))) - (insert group ;Group name - (if (nth 1 newsrc) ": " "! ")) ;Subscribed? - (gnus-ranges-to-newsrc-format (nthcdr 2 newsrc)) ;Read articles - (insert "\n") - ))) - ))) - -(defun gnus-gnus-to-quick-newsrc-format () - "Insert GNUS variables such as `gnus-newsrc-assoc' in Lisp format." - (insert ";; GNUS internal format of .newsrc.\n") - (insert ";; Touch .newsrc instead if you think to remove this file.\n") - (let ((variable nil) - (variables gnus-variable-list) - ;; Temporary rebind to make changes - ;; gnus-check-killed-newsgroups in invisible. - (gnus-killed-assoc gnus-killed-assoc) - (gnus-killed-hashtb gnus-killed-hashtb)) - ;; Remove duplicated or unsubscribed newsgroups in - ;; gnus-killed-assoc (and gnus-killed-hashtb). - (gnus-check-killed-newsgroups) - ;; Then, insert lisp expressions. - (while variables - (setq variable (car variables)) - (and (boundp variable) - (symbol-value variable) - (insert "(setq " (symbol-name variable) " '" - (prin1-to-string (symbol-value variable)) - ")\n")) - (setq variables (cdr variables))) - )) - -(defun gnus-ranges-to-newsrc-format (ranges) - "Insert ranges of read articles." - (let ((range nil)) ;Range is a pair of BEGIN and END. - (while ranges - (setq range (car ranges)) - (setq ranges (cdr ranges)) - (cond ((= (car range) (cdr range)) - (if (= (car range) 0) - (setq ranges nil) ;No unread articles. - (insert (int-to-string (car range))) - (if ranges (insert ",")) - )) - (t - (insert (int-to-string (car range)) - "-" - (int-to-string (cdr range))) - (if ranges (insert ",")) - )) - ))) - -(defun gnus-compress-sequence (numbers) - "Convert list of sorted numbers to ranges." - (let* ((numbers (sort (copy-sequence numbers) (function <))) - (first (car numbers)) - (last (car numbers)) - (result nil)) - (while numbers - (cond ((= last (car numbers)) nil) ;Omit duplicated number - ((= (1+ last) (car numbers)) ;Still in sequence - (setq last (car numbers))) - (t ;End of one sequence - (setq result (cons (cons first last) result)) - (setq first (car numbers)) - (setq last (car numbers))) - ) - (setq numbers (cdr numbers)) - ) - (nreverse (cons (cons first last) result)) - )) - -(defun gnus-uncompress-sequence (ranges) - "Expand compressed format of sequence." - (let ((first nil) - (last nil) - (result nil)) - (while ranges - (setq first (car (car ranges))) - (setq last (cdr (car ranges))) - (while (< first last) - (setq result (cons first result)) - (setq first (1+ first))) - (setq result (cons first result)) - (setq ranges (cdr ranges)) - ) - (nreverse result) - )) - -(defun gnus-number-of-articles (range) - "Compute number of articles from RANGE `((beg1 . end1) (beg2 . end2) ...)'." - (let ((count 0)) - (while range - (if (/= (cdr (car range)) 0) - ;; If end1 is 0, it must be skipped. Usually no articles in - ;; this group. - (setq count (+ count 1 (- (cdr (car range)) (car (car range)))))) - (setq range (cdr range)) - ) - count ;Result - )) - -(defun gnus-difference-of-range (src obj) - "Compute (SRC - OBJ) on range. -Range of SRC is expressed as `(beg . end)'. -Range of OBJ is expressed as `((beg1 . end1) (beg2 . end2) ...)." - (let ((beg (car src)) - (end (cdr src)) - (range nil)) ;This is result. - ;; Src may be nil. - (while (and src obj) - (let ((beg1 (car (car obj))) - (end1 (cdr (car obj)))) - (cond ((> beg end) - (setq obj nil)) ;Terminate loop - ((< beg beg1) - (setq range (cons (cons beg (min (1- beg1) end)) range)) - (setq beg (1+ end1))) - ((>= beg beg1) - (setq beg (max beg (1+ end1)))) - ) - (setq obj (cdr obj)) ;Next OBJ - )) - ;; Src may be nil. - (if (and src (<= beg end)) - (setq range (cons (cons beg end) range))) - ;; Result - (if range - (nreverse range) - (list (cons 0 0))) - )) - -(defun gnus-read-distributions-file () - "Get distributions file from NNTP server (NNTP2 functionality)." - ;; Make sure a connection to NNTP server is alive. - (gnus-start-news-server) - (message "Reading distributions file...") - (setq gnus-distribution-list nil) - (if (gnus-request-list-distributions) - (save-excursion - (set-buffer nntp-server-buffer) - (gnus-distributions-to-gnus-format) - (message "Reading distributions file...done")) - ;; It's not a fatal error. - ;;(error "Cannot read distributions file from NNTP server.") - ) - ;; Merge with user supplied default distributions. - (let ((defaults (reverse gnus-local-distributions)) - (dist nil)) - (while defaults - (setq dist (assoc (car defaults) gnus-distribution-list)) - (if dist - (setq gnus-distribution-list - (delq dist gnus-distribution-list))) - (setq gnus-distribution-list - (cons (list (car defaults)) gnus-distribution-list)) - (setq defaults (cdr defaults)) - ))) - -(defun gnus-distributions-to-gnus-format () - "Convert distributions file format to internal format." - (setq gnus-distribution-list nil) - (goto-char (point-min)) - (while (re-search-forward "^\\([^ \t\n]+\\).*$" nil t) - (setq gnus-distribution-list - (cons (list (buffer-substring (match-beginning 1) (match-end 1))) - gnus-distribution-list))) - (setq gnus-distribution-list - (nreverse gnus-distribution-list))) - -(defun gnus-newsgroups-retrieve-description () - "Retrieve newsgroups description and build gnus-newsgroups-alist" - (message "Reading newsgroups file...") - (if (gnus-request-list-newsgroups) - (save-excursion - (setq gnus-newsgroups-alist nil) - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (while (re-search-forward gnus-newsgroups-regex nil t) - (setq gnus-newsgroups-alist - (cons (cons (buffer-substring (match-beginning 1) (match-end 1)) - (buffer-substring (match-beginning 2) (match-end 2))) - gnus-newsgroups-alist))) - (message "Reading newsgroups file...done")) - (message "Cannot read newsgroups file"))) - -(defun gnus-newsgroups-update-description () - "Update the newsgroups description" - (interactive) - (gnus-newsgroups-retrieve-description) - (setq gnus-newsgroups-hashtb (gnus-make-hashtable-from-alist gnus-newsgroups-alist))) - -(defun gnus-newsgroups-display-toggle () - "Toggle displaying newsgroup descriptions in *Newsgroup* buffer." - (interactive) - (setq gnus-newsgroups-display (not gnus-newsgroups-display)) - (if gnus-newsgroups-showall - (gnus-group-list-groups t) - (gnus-group-list-groups nil))) - -(provide 'gnus) - -;;Local variables: -;;eval: (put 'gnus-eval-in-buffer-window 'lisp-indent-hook 1) -;;end: - -;;; gnus.el ends here
--- a/lisp/=gnusmail.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,220 +0,0 @@ -;;; gnusmail.el --- mail reply commands for GNUS newsreader - -;; Copyright (C) 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; Keywords: news - -;; 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: - -;; Provides mail reply and mail other window command using usual mail -;; interface and mh-e interface. -;; -;; To use MAIL: set the variables gnus-mail-reply-method and -;; gnus-mail-other-window-method to gnus-mail-reply-using-mail and -;; gnus-mail-other-window-using-mail, respectively. -;; -;; To use MH-E: set the variables gnus-mail-reply-method and -;; gnus-mail-other-window-method to gnus-mail-reply-using-mhe and -;; gnus-mail-other-window-using-mhe, respectively. - -;;; Code: - -(require 'gnus) - -(autoload 'news-mail-reply "rnewspost") -(autoload 'news-mail-other-window "rnewspost") - -(autoload 'mh-send "mh-e") -(autoload 'mh-send-other-window "mh-e") -(autoload 'mh-find-path "mh-e") -(autoload 'mh-yank-cur-msg "mh-e") - -;;; Mail reply commands of GNUS Summary Mode - -(defun gnus-summary-reply (yank) - "Reply mail to news author. -If prefix argument YANK is non-nil, original article is yanked automatically. -Customize the variable gnus-mail-reply-method to use another mailer." - (interactive "P") - ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells) - ;; Stripping headers should be specified with mail-yank-ignored-headers. - (gnus-summary-select-article t t) - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (bury-buffer gnus-article-buffer) - (funcall gnus-mail-reply-method yank)) - -(defun gnus-summary-reply-with-original () - "Reply mail to news author with original article. -Customize the variable gnus-mail-reply-method to use another mailer." - (interactive) - (gnus-summary-reply t)) - -(defun gnus-summary-mail-forward () - "Forward the current message to another user. -Customize the variable gnus-mail-forward-method to use another mailer." - (interactive) - (gnus-summary-select-article) - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (bury-buffer gnus-article-buffer) - (funcall gnus-mail-forward-method)) - -(defun gnus-summary-mail-other-window () - "Compose mail in other window. -Customize the variable gnus-mail-other-window-method to use another mailer." - (interactive) - (gnus-summary-select-article) - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (bury-buffer gnus-article-buffer) - (funcall gnus-mail-other-window-method)) - - -;;; Send mail using sendmail mail mode. - -(defun gnus-mail-reply-using-mail (&optional yank) - "Compose reply mail using mail. -Optional argument YANK means yank original article." - (news-mail-reply) - (gnus-overload-functions) - (if yank - (mail-yank-original nil))) - -(defun gnus-mail-forward-using-mail () - "Forward the current message to another user using mail." - ;; This is almost a carbon copy of rmail-forward in rmail.el. - (let ((forward-buffer (current-buffer)) - (subject - (concat "[" gnus-newsgroup-name "] " - ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": " - (or (gnus-fetch-field "Subject") "")))) - ;; If only one window, use it for the mail buffer. - ;; Otherwise, use another window for the mail buffer - ;; so that the Rmail buffer remains visible - ;; and sending the mail will get back to it. - (if (if (one-window-p t) - (mail nil nil subject) - (mail-other-window nil nil subject)) - (save-excursion - (goto-char (point-max)) - (insert "------- Start of forwarded message -------\n") - (insert-buffer forward-buffer) - (goto-char (point-max)) - (insert "------- End of forwarded message -------\n") - ;; You have a chance to arrange the message. - (run-hooks 'gnus-mail-forward-hook) - )))) - -(defun gnus-mail-other-window-using-mail () - "Compose mail other window using mail." - (news-mail-other-window) - (gnus-overload-functions)) - - -;;; Send mail using mh-e. - -;; The following mh-e interface is all cooperative works of -;; tanaka@flab.fujitsu.CO.JP (TANAKA Hiroshi), kawabe@sra.CO.JP -;; (Yoshikatsu Kawabe), and shingu@casund.cpr.canon.co.jp (Toshiaki -;; SHINGU). - -(defun gnus-mail-reply-using-mhe (&optional yank) - "Compose reply mail using mh-e. -Optional argument YANK means yank original article. -The command \\[mh-yank-cur-msg] yank the original message into current buffer." - ;; First of all, prepare mhe mail buffer. - (let (from cc subject date to reply-to (buffer (current-buffer))) - (save-restriction - (gnus-article-show-all-headers) ;I don't think this is really needed. - (setq from (gnus-fetch-field "from") - subject (let ((subject (or (gnus-fetch-field "subject") - "(None)"))) - (if (and subject - (not (string-match "^[Rr][Ee]:.+$" subject))) - (concat "Re: " subject) subject)) - reply-to (gnus-fetch-field "reply-to") - cc (gnus-fetch-field "cc") - date (gnus-fetch-field "date")) - (setq mh-show-buffer buffer) - (setq to (or reply-to from)) - (mh-find-path) - (mh-send to (or cc "") subject) - (save-excursion - (mh-insert-fields - "In-reply-to:" - (concat - (substring from 0 (string-match " *at \\| *@ \\| *(\\| *<" from)) - "'s message of " date))) - (setq mh-sent-from-folder buffer) - (setq mh-sent-from-msg 1) - )) - ;; Then, yank original article if requested. - (if yank - (let ((last (point))) - (mh-yank-cur-msg) - (goto-char last) - ))) - -;; gnus-mail-forward-using-mhe is contributed by Jun-ichiro Itoh -;; <itojun@ingram.mt.cs.keio.ac.jp> - -(defun gnus-mail-forward-using-mhe () - "Forward the current message to another user using mh-e." - ;; First of all, prepare mhe mail buffer. - (let ((to (read-string "To: ")) - (cc (read-string "Cc: ")) - (buffer (current-buffer)) - subject) - ;;(gnus-article-show-all-headers) - (setq subject - (concat "[" gnus-newsgroup-name "] " - ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": " - (or (gnus-fetch-field "subject") ""))) - (setq mh-show-buffer buffer) - (mh-find-path) - (mh-send to (or cc "") subject) - (save-excursion - (goto-char (point-max)) - (insert "\n------- Forwarded Message\n\n") - (insert-buffer buffer) - (goto-char (point-max)) - (insert "\n------- End of Forwarded Message\n") - (setq mh-sent-from-folder buffer) - (setq mh-sent-from-msg 1)))) - -(defun gnus-mail-other-window-using-mhe () - "Compose mail other window using mh-e." - (let ((to (read-string "To: ")) - (cc (read-string "Cc: ")) - (subject (read-string "Subject: " (gnus-fetch-field "subject")))) - (gnus-article-show-all-headers) ;I don't think this is really needed. - (setq mh-show-buffer (current-buffer)) - (mh-find-path) - (mh-send-other-window to cc subject) - (setq mh-sent-from-folder (current-buffer)) - (setq mh-sent-from-msg 1))) - -(provide 'gnusmail) - -;;; gnusmail.el ends here
--- a/lisp/=gnusmisc.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,294 +0,0 @@ -;;; gnusmisc.el --- miscellaneous commands for GNUS newsreader - -;; Copyright (C) 1989, 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; Keywords: news - -;; 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. - -;;; Code: - -(require 'gnus) - -;;; -;;; GNUS Browse-Killed Mode -;;; - -;; Some ideas are due to roland@wheaties.ai.mit.edu (Roland McGrath). -;; I'd like to thank him very much. - -(defvar gnus-browse-killed-mode-hook nil - "*A hook for GNUS Browse-Killed Mode.") - -(defvar gnus-browse-killed-buffer "*Killed Newsgroup*") -(defvar gnus-browse-killed-mode-map nil) -(defvar gnus-winconf-browse-killed nil) - -(autoload 'timezone-make-date-arpa-standard "timezone") - -(put 'gnus-browse-killed-mode 'mode-class 'special) - - -;;; -;;; GNUS Browse-Killed Mode -;;; - -;; Some ideas are due to roland@wheaties.ai.mit.edu (Roland McGrath). -;; I'd like to thank him very much. - -;; Make the buffer to be managed by GNUS. - -(or (memq gnus-browse-killed-buffer gnus-buffer-list) - (setq gnus-buffer-list - (cons gnus-browse-killed-buffer gnus-buffer-list))) - -(if gnus-browse-killed-mode-map - nil - (setq gnus-browse-killed-mode-map (make-keymap)) - (suppress-keymap gnus-browse-killed-mode-map t) - (define-key gnus-browse-killed-mode-map " " 'gnus-group-next-group) - (define-key gnus-browse-killed-mode-map "\177" 'gnus-group-prev-group) - (define-key gnus-browse-killed-mode-map "\C-n" 'gnus-group-next-group) - (define-key gnus-browse-killed-mode-map "\C-p" 'gnus-group-prev-group) - (define-key gnus-browse-killed-mode-map "n" 'gnus-group-next-group) - (define-key gnus-browse-killed-mode-map "p" 'gnus-group-prev-group) - (define-key gnus-browse-killed-mode-map "y" 'gnus-browse-killed-yank) - (define-key gnus-browse-killed-mode-map "\C-y" 'gnus-browse-killed-yank) - (define-key gnus-browse-killed-mode-map "l" 'gnus-list-killed-groups) - (define-key gnus-browse-killed-mode-map "q" 'gnus-browse-killed-exit) - (define-key gnus-browse-killed-mode-map "\C-c\C-c" 'gnus-browse-killed-exit) - (define-key gnus-browse-killed-mode-map "\C-c\C-i" 'gnus-info-find-node)) - -(defun gnus-browse-killed-mode () - "Major mode for browsing the killed newsgroups. -All normal editing commands are turned off. -Instead, these commands are available: -\\{gnus-browse-killed-mode-map} - -The killed newsgroups are saved in the quick startup file (.newsrc.el) -unless it against the options line in the startup file (.newsrc). - -Entry to this mode calls gnus-browse-killed-mode-hook with no arguments, -if that value is non-nil." - (interactive) - (kill-all-local-variables) - ;; Gee. Why don't you upgrade? - (cond ((boundp 'mode-line-modified) - (setq mode-line-modified "--- ")) - ((listp (default-value 'mode-line-format)) - (setq mode-line-format - (cons "--- " (cdr (default-value 'mode-line-format))))) - (t - (setq mode-line-format - "--- GNUS: Killed Newsgroups %[(%m)%]----%3p-%-"))) - (setq major-mode 'gnus-browse-killed-mode) - (setq mode-name "Browse-Killed") - (setq mode-line-buffer-identification "GNUS: Killed Newsgroups") - (use-local-map gnus-browse-killed-mode-map) - (buffer-flush-undo (current-buffer)) - (setq buffer-read-only t) ;Disable modification - (run-hooks 'gnus-browse-killed-mode-hook)) - -(defun gnus-list-killed-groups () - "List the killed newsgroups. -The keys y and C-y yank the newsgroup on the current line into the -Newsgroups buffer." - (interactive) - (or gnus-killed-assoc - (error "No killed newsgroups")) - ;; Save current window configuration if this is first invocation.. - (or (get-buffer-window gnus-browse-killed-buffer) - (setq gnus-winconf-browse-killed - (current-window-configuration))) - ;; Prepare browsing buffer. - (pop-to-buffer (get-buffer-create gnus-browse-killed-buffer)) - (gnus-browse-killed-mode) - (let ((buffer-read-only nil) - (killed-assoc gnus-killed-assoc)) - (erase-buffer) - (while killed-assoc - (insert (gnus-group-prepare-line (car killed-assoc))) - (setq killed-assoc (cdr killed-assoc))) - (goto-char (point-min)) - )) - -(defun gnus-browse-killed-yank () - "Yank current newsgroup to Newsgroup buffer." - (interactive) - (let ((group (gnus-group-group-name))) - (if group - (let* ((buffer-read-only nil) - (killed (gnus-gethash group gnus-killed-hashtb))) - (pop-to-buffer gnus-group-buffer) ;Needed to adjust point. - (if killed - (gnus-group-insert-group killed)) - (pop-to-buffer gnus-browse-killed-buffer) - (beginning-of-line) - (delete-region (point) - (progn (forward-line 1) (point))) - ))) - (gnus-browse-killed-check-buffer)) - -(defun gnus-browse-killed-check-buffer () - "Exit if the buffer is empty by deleting the window and killing the buffer." - (and (null gnus-killed-assoc) - (get-buffer gnus-browse-killed-buffer) - (gnus-browse-killed-exit))) - -(defun gnus-browse-killed-exit () - "Exit this mode by deleting the window and killing the buffer." - (interactive) - (and (get-buffer-window gnus-browse-killed-buffer) - (delete-window (get-buffer-window gnus-browse-killed-buffer))) - (kill-buffer gnus-browse-killed-buffer) - ;; Restore previous window configuration if available. - (and gnus-winconf-browse-killed - (set-window-configuration gnus-winconf-browse-killed)) - (setq gnus-winconf-browse-killed nil)) - - -;;; -;;; kill/yank newsgroup commands of GNUS Group Mode -;;; - -(defun gnus-group-transpose-groups (arg) - "Exchange current newsgroup and previous newsgroup. -With argument ARG, takes previous newsgroup and moves it past ARG newsgroup." - (interactive "p") - ;; BUG: last newsgroup and the last but one cannot be transposed - ;; since gnus-group-search-forward does not move forward beyond the - ;; last. If we instead use forward-line, no problem, but I don't - ;; want to use it for later extension. - (while (> arg 0) - (gnus-group-search-forward t t) - (gnus-group-kill-group 1) - (gnus-group-search-forward nil t) - (gnus-group-yank-group) - (gnus-group-search-forward nil t) - (setq arg (1- arg)) - )) - -(defun gnus-group-kill-region (begin end) - "Kill newsgroups in current region (excluding current point). -The killed newsgroups can be yanked by using \\[gnus-group-yank-group]." - (interactive "r") - (let ((lines - ;; Exclude a line where current point is on. - (1- - ;; Count lines. - (save-excursion - (count-lines - (progn - (goto-char begin) - (beginning-of-line) - (point)) - (progn - (goto-char end) - (end-of-line) - (point))))))) - (goto-char begin) - (beginning-of-line) ;Important when LINES < 1 - (gnus-group-kill-group lines))) - -(defun gnus-group-kill-group (n) - "Kill newsgroup on current line, repeated prefix argument N times. -The killed newsgroups can be yanked by using \\[gnus-group-yank-group]." - (interactive "p") - (let ((buffer-read-only nil) - (group nil)) - (while (> n 0) - (setq group (gnus-group-group-name)) - (or group - (signal 'end-of-buffer nil)) - (beginning-of-line) - (delete-region (point) - (progn (forward-line 1) (point))) - (gnus-kill-newsgroup group) - (setq n (1- n)) - ;; Add to killed newsgroups in the buffer if exists. - (if (get-buffer gnus-browse-killed-buffer) - (save-excursion - (set-buffer gnus-browse-killed-buffer) - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (insert (gnus-group-prepare-line (car gnus-killed-assoc))) - ))) - ) - (search-forward ":" nil t) - )) - -(defun gnus-group-yank-group () - "Yank the last newsgroup killed with \\[gnus-group-kill-group], -inserting it before the newsgroup on the line containing point." - (interactive) - (gnus-group-insert-group (car gnus-killed-assoc)) - ;; Remove killed newsgroups from the buffer if exists. - (if (get-buffer gnus-browse-killed-buffer) - (save-excursion - (set-buffer gnus-browse-killed-buffer) - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (delete-region (point-min) - (progn (forward-line 1) (point))) - ))) - (gnus-browse-killed-check-buffer)) - -(defun gnus-group-insert-group (info) - "Insert newsgroup at current line using gnus-newsrc-assoc INFO." - (if (null gnus-killed-assoc) - (error "No killed newsgroups")) - ;; Huuum. It this right? - ;;(if (not gnus-have-all-newsgroups) - ;; (error - ;; (substitute-command-keys - ;; "Not all newsgroups are displayed. Type \\[gnus-group-list-all-groups] to display all newsgroups."))) - (let ((buffer-read-only nil) - (group (gnus-group-group-name))) - (gnus-insert-newsgroup info group) - (beginning-of-line) - (insert (gnus-group-prepare-line info)) - (forward-line -1) - (search-forward ":" nil t) - )) - - -;;; Rewrite Date: field in GMT to local - -(defun gnus-gmt-to-local () - "Rewrite Date: field described in GMT to local in current buffer. -The variable gnus-local-timezone is used for local time zone. -Intended to be used with gnus-article-prepare-hook." - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (narrow-to-region (point-min) - (progn (search-forward "\n\n" nil 'move) (point))) - (goto-char (point-min)) - (if (re-search-forward "^Date:[ \t]\\(.*\\)$" nil t) - (let ((buffer-read-only nil) - (date (buffer-substring (match-beginning 1) (match-end 1)))) - (delete-region (match-beginning 1) (match-end 1)) - (insert - (timezone-make-date-arpa-standard date nil gnus-local-timezone)) - )) - ))) - -(provide 'gnusmisc) - -;;; gnusmisc.el ends here
--- a/lisp/=gnuspost.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,842 +0,0 @@ -;;; gnuspost.el --- post news commands for GNUS newsreader - -;; Copyright (C) 1989, 1990, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; Keywords: news - -;; 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. - -;;; Code: - -(require 'gnus) - -(defvar gnus-organization-file "/usr/lib/news/organization" - "*Local news organization file.") - -(defvar gnus-post-news-buffer "*post-news*") -(defvar gnus-winconf-post-news nil) - -(autoload 'news-reply-mode "rnewspost") -(autoload 'timezone-make-date-arpa-standard "timezone") - -;;; Post news commands of GNUS Group Mode and Summary Mode - -(defun gnus-group-post-news () - "Post an article." - (interactive) - ;; Save window configuration. - (setq gnus-winconf-post-news (current-window-configuration)) - (unwind-protect - (gnus-post-news) - (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) - (not (zerop (buffer-size)))) - ;; Restore last window configuration. - (set-window-configuration gnus-winconf-post-news))) - ;; We don't want to return to Summary buffer nor Article buffer later. - (if (get-buffer gnus-summary-buffer) - (bury-buffer gnus-summary-buffer)) - (if (get-buffer gnus-article-buffer) - (bury-buffer gnus-article-buffer))) - -(defun gnus-summary-post-news () - "Post an article." - (interactive) - (gnus-summary-select-article t nil) - ;; Save window configuration. - (setq gnus-winconf-post-news (current-window-configuration)) - (unwind-protect - (progn - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (gnus-post-news)) - (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) - (not (zerop (buffer-size)))) - ;; Restore last window configuration. - (set-window-configuration gnus-winconf-post-news))) - ;; We don't want to return to Article buffer later. - (bury-buffer gnus-article-buffer)) - -(defun gnus-summary-followup (yank) - "Post a reply article. -If prefix argument YANK is non-nil, original article is yanked automatically." - (interactive "P") - (gnus-summary-select-article t nil) - ;; Check Followup-To: poster. - (set-buffer gnus-article-buffer) - (if (and gnus-use-followup-to - (string-equal "poster" (gnus-fetch-field "followup-to")) - (or (not (eq gnus-use-followup-to t)) - (not (y-or-n-p "Do you want to ignore `Followup-To: poster'? ")))) - ;; Mail to the poster. GNUS is now RFC1036 compliant. - (gnus-summary-reply yank) - ;; Save window configuration. - (setq gnus-winconf-post-news (current-window-configuration)) - (unwind-protect - (progn - (switch-to-buffer gnus-article-buffer) - (widen) - (delete-other-windows) - (gnus-news-reply yank)) - (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer)) - (not (zerop (buffer-size)))) - ;; Restore last window configuration. - (set-window-configuration gnus-winconf-post-news))) - ;; We don't want to return to Article buffer later. - (bury-buffer gnus-article-buffer))) - -(defun gnus-summary-followup-with-original () - "Post a reply article with original article." - (interactive) - (gnus-summary-followup t)) - -(defun gnus-summary-cancel-article () - "Cancel an article you posted." - (interactive) - (gnus-summary-select-article t nil) - (gnus-eval-in-buffer-window gnus-article-buffer - (gnus-cancel-news))) - - -;;; Post a News using NNTP - -;;;###autoload -(defalias 'sendnews 'gnus-post-news) - -;;;###autoload -(defalias 'postnews 'gnus-post-news) - -;;;###autoload -(defun gnus-post-news () - "Begin editing a new USENET news article to be posted. -Type \\[describe-mode] once editing the article to get a list of commands." - (interactive) - (if (or (not gnus-novice-user) - (y-or-n-p "Are you sure you want to post to all of USENET? ")) - (let ((artbuf (current-buffer)) - (newsgroups ;Default newsgroup. - (if (eq major-mode 'gnus-article-mode) gnus-newsgroup-name)) - (subject nil) - ;; Get default distribution. - (distribution (car gnus-local-distributions)) - (followup-to nil)) - ;; Connect to NNTP server if not connected yet, and get - ;; several information. - (if (not (gnus-server-opened)) - (progn - (gnus-start-news-server t) ;Confirm server. - (gnus-setup-news))) - ;; Get current article information. - (save-restriction - (and (not (zerop (buffer-size))) - ;;(equal major-mode 'news-mode) - (equal major-mode 'gnus-article-mode) - (progn - ;;(news-show-all-headers) - (gnus-article-show-all-headers) - (narrow-to-region (point-min) - (progn (goto-char (point-min)) - (search-forward "\n\n") - (point))))) - (setq news-reply-yank-from (mail-fetch-field "from")) - (setq news-reply-yank-message-id (mail-fetch-field "message-id"))) - (pop-to-buffer gnus-post-news-buffer) - (news-reply-mode) - (gnus-overload-functions) - (if (and (buffer-modified-p) - (> (buffer-size) 0) - (not (y-or-n-p "Unsent article being composed; erase it? "))) - ;; Continue composition. - ;; Make news-reply-yank-original work on the current article. - (setq mail-reply-buffer artbuf) - (erase-buffer) - (if gnus-interactive-post - ;; Newsgroups, subject and distribution are asked for. - ;; Suggested by yuki@flab.fujitsu.junet. - (progn - ;; Subscribed newsgroup names are required for - ;; completing read of newsgroup. - (or gnus-newsrc-assoc - (gnus-read-newsrc-file)) - ;; Which do you like? (UMERIN) - ;; (setq newsgroups (read-string "Newsgroups: " "general")) - (or newsgroups ;Use the default newsgroup. - (let (group) - (while (not - (string= - (setq group - (completing-read "Newsgroup: " - gnus-newsrc-assoc - nil 'require-match)) - "")) - (or followup-to (setq followup-to group)) - (if newsgroups - (setq newsgroups (concat newsgroups "," group)) - (setq newsgroups group))))) - (setq subject (read-string "Subject: ")) - ;; Choose a distribution from gnus-distribution-list. - ;; completing-read should not be used with - ;; 'require-match functionality in order to allow use - ;; of unknow distribution. - (gnus-read-distributions-file) - (setq distribution - (if (consp gnus-distribution-list) - (completing-read "Distribution: " - gnus-distribution-list - nil nil ;Never 'require-match - distribution ;Default distribution. - ) - (read-string "Distribution: "))) - ;; Empty string is okay. - ;;(if (string-equal distribution "") - ;; (setq distribution nil)) - )) - (news-setup () subject () newsgroups artbuf) - ;; Make sure the article is posted by GNUS. - ;;(mail-position-on-field "Posting-Software") - ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs") - ;; Insert Distribution: field. - ;; Suggested by ichikawa@flab.fujitsu.junet. - (mail-position-on-field "Distribution") - (insert (or distribution "")) - ;; Add Followup-To header - (if followup-to - (progn - (mail-position-on-field "Followup-To") - (insert followup-to))) - ;; Handle author copy using FCC field. - (if gnus-author-copy - (progn - (mail-position-on-field "FCC") - (insert gnus-author-copy))) - (if gnus-interactive-post - ;; All fields are filled in. - (goto-char (point-max)) - ;; Move point to Newsgroup: field. - (goto-char (point-min)) - (end-of-line)) - )) - (message ""))) - -(defun gnus-news-reply (&optional yank) - "Compose and post a reply (aka a followup) to the current article on USENET. -While composing the followup, use \\[news-reply-yank-original] to yank the -original message into it." - (interactive) - (if (or (not gnus-novice-user) - (y-or-n-p "Are you sure you want to followup to all of USENET? ")) - (let (from cc subject date to followup-to newsgroups message-of - references distribution message-id - (artbuf (current-buffer))) - (save-restriction - (and (not (zerop (buffer-size))) - ;;(equal major-mode 'news-mode) - (equal major-mode 'gnus-article-mode) - (progn - ;; (news-show-all-headers) - (gnus-article-show-all-headers) - (narrow-to-region (point-min) - (progn (goto-char (point-min)) - (search-forward "\n\n") - (point))))) - (setq from (mail-fetch-field "from")) - ;; Get reply-to working corrrectly for gnus-auto-mail-to-author (jpm) - (setq reply-to (mail-fetch-field "reply-to")) - (setq news-reply-yank-from from) - (setq subject (mail-fetch-field "subject")) - (setq date (mail-fetch-field "date")) - (setq followup-to (mail-fetch-field "followup-to")) - ;; Ignore Followup-To: poster. - (if (or (null gnus-use-followup-to) ;Ignore followup-to: field. - (string-equal "" followup-to) ;Bogus header. - (string-equal "poster" followup-to)) - (setq followup-to nil)) - (setq newsgroups (or followup-to (mail-fetch-field "newsgroups"))) - (setq references (mail-fetch-field "references")) - (setq distribution (mail-fetch-field "distribution")) - (setq message-id (mail-fetch-field "message-id")) - (setq news-reply-yank-message-id message-id)) - (pop-to-buffer gnus-post-news-buffer) - (news-reply-mode) - (gnus-overload-functions) - (if (and (buffer-modified-p) - (> (buffer-size) 0) - (not (y-or-n-p "Unsent article being composed; erase it? "))) - ;; Continue composition. - ;; Make news-reply-yank-original work on current article. - (setq mail-reply-buffer artbuf) - (erase-buffer) - (and subject - (setq subject - (concat "Re: " (gnus-simplify-subject subject 're-only)))) - (and from - (progn - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) - (setq message-of - (concat - (if stop-pos (substring from 0 stop-pos) from) - "'s message of " - date))))) - (news-setup nil subject message-of newsgroups artbuf) - (if followup-to - (progn (news-reply-followup-to) - (insert followup-to))) - ;; Fold long references line to follow RFC1036. - (mail-position-on-field "References") - (let ((begin (point)) - (fill-column 79) - (fill-prefix "\t")) - (if references - (insert references)) - (if (and references message-id) - (insert " ")) - (if message-id - (insert message-id)) - ;; The region must end with a newline to fill the region - ;; without inserting extra newline. - (fill-region-as-paragraph begin (1+ (point)))) - ;; Make sure the article is posted by GNUS. - ;;(mail-position-on-field "Posting-Software") - ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs") - ;; Distribution must be the same as original article. - (mail-position-on-field "Distribution") - (insert (or distribution "")) - ;; Handle author copy using FCC field. - (if gnus-author-copy - (progn - (mail-position-on-field "FCC") - (insert gnus-author-copy))) - ;; Insert To: FROM field, which is expected to mail the - ;; message to the author of the article too. Use Reply-To - ;; field like gnus-mail-reply-using-m* (jpm). - (if (and gnus-auto-mail-to-author (or reply-to from)) - (progn - (goto-char (point-min)) - (insert "To: " (or reply-to from) "\n"))) - (goto-char (point-max))) - ;; Yank original article automatically. - (if yank - (let ((last (point))) - ;;(goto-char (point-max)) - ;; Insert at current point. - (news-reply-yank-original nil) - (goto-char last))) - ) - (message ""))) - -(defun gnus-inews-news () - "Send a news message." - (interactive) - (let* ((case-fold-search nil) - (server-running (gnus-server-opened))) - (save-excursion - ;; Connect to default NNTP server if necessary. - ;; Suggested by yuki@flab.fujitsu.junet. - (gnus-start-news-server) ;Use default server. - ;; NNTP server must be opened before current buffer is modified. - (widen) - (goto-char (point-min)) - (run-hooks 'news-inews-hook) - (save-restriction - (narrow-to-region - (point-min) - (progn - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n")) - (point))) - - ;; Correct newsgroups field: change sequence of spaces to comma and - ;; eliminate spaces around commas. Eliminate imbedded line breaks. - (goto-char (point-min)) - (if (search-forward-regexp "^Newsgroups: +" nil t) - (save-restriction - (narrow-to-region - (point) - (if (re-search-forward "^[^ \t]" nil 'end) - (match-beginning 0) - (point-max))) - (goto-char (point-min)) - (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing) - (goto-char (point-min)) - (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",") - )) - - ;; Mail the message too if To: or Cc: exists. - (if (or (mail-fetch-field "to" nil t) - (mail-fetch-field "cc" nil t)) - (if gnus-mail-send-method - (progn - (message "Sending via mail...") - (widen) - (funcall gnus-mail-send-method) - (message "Sending via mail... done")) - (ding) - (message "No mailer defined. To: and/or Cc: fields ignored.") - (sit-for 1)))) - - ;; Send to NNTP server. - (message "Posting to USENET...") - (if (gnus-inews-article) - (message "Posting to USENET... done") - ;; We cannot signal an error. - (ding) (message "Article rejected: %s" (gnus-status-message))) - (set-buffer-modified-p nil)) - ;; If NNTP server is opened by gnus-inews-news, close it by myself. - (or server-running - (gnus-close-server)) - (and (fboundp 'bury-buffer) (bury-buffer)) - ;; Restore last window configuration. - (and gnus-winconf-post-news - (set-window-configuration gnus-winconf-post-news)) - (setq gnus-winconf-post-news nil) - )) - -(defun gnus-cancel-news () - "Cancel an article you posted." - (interactive) - (if (yes-or-no-p "Do you really want to cancel this article? ") - (let ((from nil) - (newsgroups nil) - (message-id nil) - (distribution nil)) - (save-excursion - ;; Get header info. from original article. - (save-restriction - (gnus-article-show-all-headers) - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (narrow-to-region (point-min) (point)) - (setq from (mail-fetch-field "from")) - (setq newsgroups (mail-fetch-field "newsgroups")) - (setq message-id (mail-fetch-field "message-id")) - (setq distribution (mail-fetch-field "distribution"))) - ;; Verify if the article is absolutely user's by comparing - ;; user id with value of its From: field. - (if (not - (string-equal - (downcase (mail-strip-quoted-names from)) - (downcase (mail-strip-quoted-names (gnus-inews-user-name))))) - (progn - (ding) (message "This article is not yours.")) - ;; Make control article. - (set-buffer (get-buffer-create " *GNUS-canceling*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert "Newsgroups: " newsgroups "\n" - "Subject: cancel " message-id "\n" - "Control: cancel " message-id "\n" - ;; We should not use the first value of - ;; `gnus-distribution-list' as default value, - ;; because distribution must be as same as original - ;; article. - "Distribution: " (or distribution "") "\n" - mail-header-separator "\n" - ) - ;; Send the control article to NNTP server. - (message "Canceling your article...") - (if (gnus-inews-article) - (message "Canceling your article... done") - (ding) (message "Failed to cancel your article")) - ;; Kill the article buffer. - (kill-buffer (current-buffer)) - ))) - )) - - -;;; Lowlevel inews interface - -(defun gnus-inews-article () - "Post an article in current buffer using NNTP protocol." - (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *GNUS-posting*"))) - (save-excursion - (set-buffer tmpbuf) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert-buffer-substring artbuf) - ;; Remove the header separator. - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n")) - (replace-match "\n\n") - (goto-char (point-max)) - ;; require a newline at the end for inews to append .signature to - (or (= (preceding-char) ?\n) - (insert ?\n)) - ;; This hook may insert a signature. - (run-hooks 'gnus-prepare-article-hook) - ;; Prepare article headers. All message body such as signature - ;; must be inserted before Lines: field is prepared. - (save-restriction - (goto-char (point-min)) - (search-forward "\n\n") - (narrow-to-region (point-min) (point)) - (gnus-inews-insert-headers)) - ;; Run final inews hooks. This hook may do FCC. - ;; The article must be saved before being posted because - ;; `gnus-request-post' modifies the buffer. - (run-hooks 'gnus-inews-article-hook) - ;; Post an article to NNTP server. - ;; Return NIL if post failed. - (prog1 - (gnus-request-post) - (kill-buffer (current-buffer))) - ))) - -(defun gnus-inews-insert-headers () - "Prepare article headers. -Fields already prepared in the buffer are not modified. -Fields in gnus-required-headers will be generated." - (save-excursion - (let ((date (gnus-inews-date)) - (message-id (gnus-inews-message-id)) - (organization (gnus-inews-organization))) - (goto-char (point-min)) - (or (mail-fetch-field "path") - (and (memq 'Path gnus-required-headers) - (insert "Path: " (gnus-inews-path) "\n"))) - (or (mail-fetch-field "from") - (and (memq 'From gnus-required-headers) - (insert "From: " (gnus-inews-user-name) "\n"))) - ;; If there is no subject, make Subject: field. - (or (mail-fetch-field "subject") - (and (memq 'Subject gnus-required-headers) - (insert "Subject: \n"))) - ;; If there is no newsgroups, make Newsgroups: field. - (or (mail-fetch-field "newsgroups") - (and (memq 'Newsgroups gnus-required-headers) - (insert "Newsgroups: \n"))) - (or (mail-fetch-field "message-id") - (and message-id - (memq 'Message-ID gnus-required-headers) - (insert "Message-ID: " message-id "\n"))) - (or (mail-fetch-field "date") - (and date - (memq 'Date gnus-required-headers) - (insert "Date: " date "\n"))) - ;; Optional fields in RFC977 and RFC1036 - (or (mail-fetch-field "organization") - (and organization - (memq 'Organization gnus-required-headers) - (let ((begin (point)) - (fill-column 79) - (fill-prefix "\t")) - (insert "Organization: " organization "\n") - (fill-region-as-paragraph begin (point))))) - (or (mail-fetch-field "distribution") - (and (memq 'Distribution gnus-required-headers) - (insert "Distribution: \n"))) - (or (mail-fetch-field "lines") - (and (memq 'Lines gnus-required-headers) - (insert "Lines: " (gnus-inews-lines) "\n"))) - ))) - - -;; Utility functions. - -(defun gnus-inews-insert-signature () - "Insert signature file in current article buffer. -If there is a file named .signature-DISTRIBUTION, it is used instead -of usual .signature when the distribution of the article is -DISTRIBUTION. Set the variable to nil to prevent appending the -signature file automatically. -Signature file is specified by the variable gnus-signature-file." - (save-excursion - (save-restriction - ;; Change signature file by distribution. - ;; Suggested by hyoko@flab.fujitsu.co.jp. - (let ((signature - (if gnus-signature-file - (expand-file-name gnus-signature-file nil))) - (distribution nil)) - (goto-char (point-min)) - (search-forward "\n\n") - (narrow-to-region (point-min) (point)) - (setq distribution (mail-fetch-field "distribution")) - (widen) - (if signature - (progn - (if (file-exists-p (concat signature "-" distribution)) - (setq signature (concat signature "-" distribution))) - ;; Insert signature. - (if (file-exists-p signature) - (progn - (goto-char (point-max)) - (insert "-- \n") - (insert-file-contents signature))) - )))))) - -(defun gnus-inews-do-fcc () - "Process FCC: fields in current article buffer. -Unless the first character of the field is `|', the article is saved -to the specified file using the function specified by the variable -gnus-author-copy-saver. The default function rmail-output saves in -Unix mailbox format. -If the first character is `|', the contents of the article is send to -a program specified by the rest of the value." - (let ((fcc-list nil) - (fcc-file nil) - (case-fold-search t)) ;Should ignore case. - (save-excursion - (save-restriction - (goto-char (point-min)) - (search-forward "\n\n") - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (while (re-search-forward "^FCC:[ \t]*" nil t) - (setq fcc-list - (cons (buffer-substring - (point) - (progn - (end-of-line) - (skip-chars-backward " \t") - (point))) - fcc-list)) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point)))) - ;; Process FCC operations. - (widen) - (while fcc-list - (setq fcc-file (car fcc-list)) - (setq fcc-list (cdr fcc-list)) - (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file) - (let ((program (substring fcc-file - (match-beginning 1) (match-end 1)))) - ;; Suggested by yuki@flab.fujitsu.junet. - ;; Send article to named program. - (call-process-region (point-min) (point-max) shell-file-name - nil nil nil "-c" program) - )) - (t - ;; Suggested by hyoko@flab.fujitsu.junet. - ;; Save article in Unix mail format by default. - (if (and gnus-author-copy-saver - (not (eq gnus-author-copy-saver 'rmail-output))) - (funcall gnus-author-copy-saver fcc-file) - (if (and (file-readable-p fcc-file) - (mail-file-babyl-p fcc-file)) - (gnus-output-to-rmail fcc-file) - (rmail-output fcc-file 1 t t))) - )) - ) - )) - )) - -(defun gnus-inews-path () - "Return uucp path." - (let ((login-name (gnus-inews-login-name))) - (cond ((null gnus-use-generic-path) - (concat gnus-nntp-server "!" login-name)) - ((stringp gnus-use-generic-path) - ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com. - (concat gnus-use-generic-path "!" login-name)) - (t login-name)) - )) - -(defun gnus-inews-user-name () - "Return user's network address as `NAME@DOMAIN (FULLNAME)'." - (let ((full-name (gnus-inews-full-name))) - (concat (if (or gnus-user-login-name gnus-use-generic-from - gnus-local-domain (getenv "DOMAINNAME")) - (concat (gnus-inews-login-name) "@" - (gnus-inews-domain-name gnus-use-generic-from)) - user-mail-address) - ;; User's full name. - (cond ((string-equal full-name "") "") - ((string-equal full-name "&") ;Unix hack. - (concat " (" login-name ")")) - (t - (concat " (" full-name ")"))) - ))) - -(defun gnus-inews-login-name () - "Return user login name. -Got from the variable `gnus-user-login-name' and the function -`user-login-name'." - (or gnus-user-login-name (user-login-name))) - -(defun gnus-inews-full-name () - "Return user full name. -Got from the variable `gnus-user-full-name', the environment variable -NAME, and the function `user-full-name'." - (or gnus-user-full-name - (getenv "NAME") (user-full-name))) - -(defun gnus-inews-domain-name (&optional genericfrom) - "Return user's domain name. -If optional argument GENERICFROM is a string, use it as the domain -name; if it is non-nil, strip of local host name from the domain name. -If the function `system-name' returns full internet name and the -domain is undefined, the domain name is got from it." - (and (null gnus-local-domain) - (boundp 'gnus-your-domain) - (setq gnus-local-domain gnus-your-domain)) - (if (or genericfrom gnus-local-domain (getenv "DOMAINNAME")) - (let ((domain (or (if (stringp genericfrom) genericfrom) - (getenv "DOMAINNAME") - gnus-local-domain - ;; Function `system-name' may return full internet name. - ;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>. - (if (string-match "\\." (system-name)) - (substring (system-name) (match-end 0))) - (read-string "Domain name (no host): "))) - (host (or (if (string-match "\\." (system-name)) - (substring (system-name) 0 (match-beginning 0))) - (system-name)))) - (if (string-equal "." (substring domain 0 1)) - (setq domain (substring domain 1))) - ;; Support GENERICFROM as same as standard Bnews system. - ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com. - (cond ((null genericfrom) - (concat host "." domain)) - ;;((stringp genericfrom) genericfrom) - (t domain))) - (substring user-mail-address (1+ (string-match "@" user-mail-address))))) - -(defun gnus-inews-message-id () - "Generate unique Message-ID for user." - ;; Message-ID should not contain a slash and should be terminated by - ;; a number. I don't know the reason why it is so. - (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-domain-name) ">")) - -(defun gnus-inews-unique-id () - "Generate unique ID from user name and current time." - (let ((date (current-time-string)) - (name (gnus-inews-login-name))) - (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) [0-9][0-9]\\([0-9][0-9]\\)" - date) - (concat (upcase name) "." - (substring date (match-beginning 6) (match-end 6)) ;Year - (substring date (match-beginning 1) (match-end 1)) ;Month - (substring date (match-beginning 2) (match-end 2)) ;Day - (substring date (match-beginning 3) (match-end 3)) ;Hour - (substring date (match-beginning 4) (match-end 4)) ;Minute - (substring date (match-beginning 5) (match-end 5)) ;Second - ) - (error "Cannot understand current-time-string: %s." date)) - )) - -(defun gnus-current-time-zone (time) - "The local time zone in effect at TIME, or nil if not known." - (let ((z (and (fboundp 'current-time-zone) (current-time-zone time)))) - (if (and z (car z)) z gnus-local-timezone))) - -(defun gnus-inews-date () - "Date string of today. -If `current-time-zone' works, or if `gnus-local-timezone' is set correctly, -this yields a date that conforms to RFC 822. Otherwise a buggy date will -be generated; this might work with some older news servers." - (let* ((now (and (fboundp 'current-time) (current-time))) - (zone (gnus-current-time-zone now))) - (if zone - (gnus-inews-valid-date now zone) - ;; No timezone info. - (gnus-inews-buggy-date now)))) - -(defun gnus-inews-valid-date (&optional time zone) - "A date string that represents TIME and conforms to the Usenet standard. -TIME is optional and defaults to the current time. -Some older versions of Emacs always act as if TIME is nil. -The optional argument ZONE specifies the local time zone (default GMT)." - (timezone-make-date-arpa-standard - (if (fboundp 'current-time) - (current-time-string time) - (current-time-string)) - zone "GMT")) - -(defun gnus-inews-buggy-date (&optional time) - "A buggy date string that represents TIME. -TIME is optional and defaults to the current time. -Some older versions of Emacs always act as if TIME is nil." - (let ((date (if (fboundp 'current-time) - (current-time-string time) - (current-time-string)))) - (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9:]+\\) [0-9][0-9]\\([0-9][0-9]\\)" - date) - (concat (substring date (match-beginning 2) (match-end 2)) ;Day - " " - (substring date (match-beginning 1) (match-end 1)) ;Month - " " - (substring date (match-beginning 4) (match-end 4)) ;Year - " " - (substring date (match-beginning 3) (match-end 3))) ;Time - (error "Cannot understand current-time-string: %s." date)) - )) - -(defun gnus-inews-organization () - "Return user's organization. -The ORGANIZATION environment variable is used if defined. -If not, the variable gnus-local-organization is used instead. -If the value begins with a slash, it is taken as the name of a file -containing the organization." - ;; The organization must be got in this order since the ORGANIZATION - ;; environment variable is intended for user specific while - ;; gnus-local-organization is for machine or organization specific. - - ;; Note: compatibility hack. This will be removed in the next version. - (and (null gnus-local-organization) - (boundp 'gnus-your-organization) - (setq gnus-local-organization gnus-your-organization)) - ;; End of compatibility hack. - (let* ((private-file (expand-file-name "~/.organization" nil)) - (organization (or (getenv "ORGANIZATION") - gnus-local-organization - private-file))) - (and (stringp organization) - (> (length organization) 0) - (string-equal (substring organization 0 1) "/") - ;; Get it from the user and system file. - ;; Suggested by roland@wheaties.ai.mit.edu (Roland McGrath). - (let ((dist (mail-fetch-field "distribution"))) - (setq organization - (cond ((file-exists-p (concat organization "-" dist)) - (concat organization "-" dist)) - ((file-exists-p organization) organization) - ((file-exists-p gnus-organization-file) - gnus-organization-file) - (t organization))) - )) - (cond ((not (stringp organization)) nil) - ((and (string-equal (substring organization 0 1) "/") - (file-exists-p organization)) - ;; If the first character is `/', assume it is the name of - ;; a file containing the organization. - (save-excursion - (let ((tmpbuf (get-buffer-create " *GNUS organization*"))) - (set-buffer tmpbuf) - (erase-buffer) - (insert-file-contents organization) - (prog1 (buffer-string) - (kill-buffer tmpbuf)) - ))) - ((string-equal organization private-file) nil) ;No such file - (t organization)) - )) - -(defun gnus-inews-lines () - "Count the number of lines and return numeric string." - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (int-to-string (count-lines (point) (point-max)))))) - -(provide 'gnuspost) - -;;; gnuspost.el ends here
--- a/lisp/=gosmacs.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,117 +0,0 @@ -;;; gosmacs.el --- rebindings to imitate Gosmacs. - -;; Copyright (C) 1986 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: emulations - -;; 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: - -;; Make GNU Emacs look like Gosling Emacs. `M-x set-gosmacs-bindings' -;; does this change; `M-x set-gnu-bindings' undoes it. - -;;; Code: - -(require 'mlsupport) - -(defvar non-gosmacs-binding-alist nil) - -;;;###autoload -(defun set-gosmacs-bindings () - "Rebind some keys globally to make GNU Emacs resemble Gosling Emacs. -Use \\[set-gnu-bindings] to restore previous global bindings." - (interactive) - (setq non-gosmacs-binding-alist - (rebind-and-record - '(("\C-x\C-e" compile) - ("\C-x\C-f" save-buffers-kill-emacs) - ("\C-x\C-i" insert-file) - ("\C-x\C-m" save-some-buffers) - ("\C-x\C-n" next-error) - ("\C-x\C-o" switch-to-buffer) - ("\C-x\C-r" insert-file) - ("\C-x\C-u" undo) - ("\C-x\C-v" find-file-other-window) - ("\C-x\C-z" shrink-window) - ("\C-x!" shell-command) - ("\C-xd" delete-window) - ("\C-xn" gosmacs-next-window) - ("\C-xp" gosmacs-previous-window) - ("\C-xz" enlarge-window) - ("\C-z" scroll-one-line-up) - ("\e\C-c" save-buffers-kill-emacs) - ("\e!" line-to-top-of-window) - ("\e(" backward-paragraph) - ("\e)" forward-paragraph) - ("\e?" apropos) - ("\eh" delete-previous-word) - ("\ej" indent-sexp) - ("\eq" query-replace) - ("\er" replace-string) - ("\ez" scroll-one-line-down) - ("\C-_" suspend-emacs))))) - -(defun rebind-and-record (bindings) - "Establish many new global bindings and record the bindings replaced. -Arg BINDINGS is an alist whose elements are (KEY DEFINITION). -Returns a similar alist whose elements describe the same KEYs -but each with the old definition that was replaced," - (let (old) - (while bindings - (let* ((this (car bindings)) - (key (car this)) - (newdef (nth 1 this))) - (setq old (cons (list key (lookup-key global-map key)) old)) - (global-set-key key newdef)) - (setq bindings (cdr bindings))) - (nreverse old))) - -(defun set-gnu-bindings () - "Restore the global bindings that were changed by \\[set-gosmacs-bindings]." - (interactive) - (rebind-and-record non-gosmacs-binding-alist)) - -(defun gosmacs-previous-window () - "Select the window above or to the left of the window now selected. -From the window at the upper left corner, select the one at the lower right." - (interactive) - (select-window (previous-window))) - -(defun gosmacs-next-window () - "Select the window below or to the right of the window now selected. -From the window at the lower right corner, select the one at the upper left." - (interactive) - (select-window (next-window))) - -(defun scroll-one-line-up (&optional arg) - "Scroll the selected window up (forward in the text) one line (or N lines)." - (interactive "p") - (scroll-up (or arg 1))) - -(defun scroll-one-line-down (&optional arg) - "Scroll the selected window down (backward in the text) one line (or N)." - (interactive "p") - (scroll-down (or arg 1))) - -(defun line-to-top-of-window () - "Scroll the selected window up so that the current line is at the top." - (interactive) - (recenter 0)) - -;;; gosmacs.el ends here
--- a/lisp/=grow-vers.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ -;;; grow-vers.el --- increment Emacs version number - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: internal - -;; 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: - -;; Load this file to add a new level (starting at zero) -;; to the Emacs version number recorded in version.el. - -;;; Code: - -(insert-file-contents "lisp/version.el") - -(re-search-forward "emacs-version \"[0-9.]*") -(insert ".0") - -;; Delete the share-link with the current version -;; so that we do not alter the current version. -(delete-file "lisp/version.el") -(write-region (point-min) (point-max) "lisp/version.el" nil 'nomsg) - -;;; grow-vers.el ends here
--- a/lisp/=inc-vers.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -;;; inc-vers.el --- load this to increment the recorded Emacs version number. - -;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: internal - -;; 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. - -;;; Code: - -(insert-file-contents "../lisp/version.el") - -(re-search-forward "emacs-version \"[^\"]*[0-9]+\"") -(forward-char -1) -(save-excursion - (save-restriction - (narrow-to-region (point) - (progn (skip-chars-backward "0-9") (point))) - (goto-char (point-min)) - (let ((version (read (current-buffer)))) - (delete-region (point-min) (point-max)) - (prin1 (1+ version) (current-buffer))))) -(skip-chars-backward "^\"") -(message "New Emacs version will be %s" - (buffer-substring (point) - (progn (skip-chars-forward "^\"") (point)))) - - -(if (and (file-accessible-directory-p "../lisp/") - (null (file-writable-p "../lisp/version.el"))) - (delete-file "../lisp/version.el")) -(if (eq system-type 'ms-dos) (setq buffer-file-type t)) -(write-region (point-min) (point-max) "../lisp/version.el" nil 'nomsg) -(erase-buffer) -(set-buffer-modified-p nil) - -(kill-emacs) - -;;; inc-vers.el ends here
--- a/lisp/=isearch-old.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,608 +0,0 @@ -;;; isearch.el --- incremental search commands - -;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. - -;; Maintainer: FSF - -;; 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. - -;;; Code: - -(defvar search-last-string "" "\ -Last string search for by a non-regexp search command. -This does not include direct calls to the primitive search functions, -and does not include searches that are aborted.") - -(defvar search-last-regexp "" "\ -Last string searched for by a regexp search command. -This does not include direct calls to the primitive search functions, -and does not include searches that are aborted.") - - -(defconst search-repeat-char ?\C-s "\ -*Character to repeat incremental search forwards.") -(defconst search-reverse-char ?\C-r "\ -*Character to repeat incremental search backwards.") -(defconst search-exit-char ?\C-m "\ -*Character to exit incremental search.") -(defconst search-delete-char ?\177 "\ -*Character to delete from incremental search string.") -(defconst search-quote-char ?\C-q "\ -*Character to quote special characters for incremental search.") -(defconst search-yank-word-char ?\C-w "\ -*Character to pull next word from buffer into search string.") -(defconst search-yank-line-char ?\C-y "\ -*Character to pull rest of line from buffer into search string.") -(defconst search-ring-advance-char ?\M-n "\ -*Character to pull next (more recent) search string from the ring of same.") -(defconst search-ring-retreat-char ?\M-p "\ -*Character to pull previous (older) search string from the ring of same.") - -(defconst search-exit-option t "\ -*Non-nil means random control characters terminate incremental search.") - -(defvar search-slow-window-lines 1 "\ -*Number of lines in slow search display windows. -These are the short windows used during incremental search on slow terminals. -Negative means put the slow search window at the top (normally it's at bottom) -and the value is minus the number of lines.") - -(defvar search-slow-speed 1200 "\ -*Highest terminal speed at which to use \"slow\" style incremental search. -This is the style where a one-line window is created to show the line -that the search has reached.") - -(defconst search-upper-case t - "*Non-nil means an upper-case letter as search input means case-sensitive. -Any upper-case letter given explicitly as input to the incremental search -has the effect of turning off `case-fold-search' for the rest of this search. -Deleting the letter from the search string cancels the effect.") - -(fset 'search-forward-regexp 're-search-forward) -(fset 'search-backward-regexp 're-search-backward) - -(defvar search-ring nil - "List of recent non-regexp incremental searches. -Each element is a cons cell of the form (STRING . UPPERCASE-FLAG).") - -(defvar regexp-search-ring nil - "List of recent regexp incremental searches. -Each element is a cons cell of the form (STRING . UPPERCASE-FLAG).") - -(defconst search-ring-max 16 - "*Maximum length of search ring before oldest elements are thrown away.") - -(defvar search-ring-yank-pointer nil - "The tail of the search ring whose car is the last thing searched for.") - -(defvar regexp-search-ring-yank-pointer nil - "The tail of the regular expression search ring whose car is the last -thing searched for.") - - -(defun isearch-forward () - "Do incremental search forward. -As you type characters, they add to the search string and are found. -Type Delete to cancel characters from end of search string. -Type RET to exit, leaving point at location found. -Type C-s to search again forward, C-r to search again backward. -Type C-w to yank word from buffer onto end of search string and search for it. -Type C-y to yank rest of line onto end of search string, etc. -Type C-q to quote control character to search for it. -Other control and meta characters terminate the search - and are then executed normally. -The above special characters are mostly controlled by parameters; - do M-x apropos on search-.*-char to find them. -C-g while searching or when search has failed - cancels input back to what has been found successfully. -C-g when search is successful aborts and moves point to starting point." - (interactive) - (isearch t)) -(define-key global-map "\C-s" 'isearch-forward) - -(defun isearch-forward-regexp () - "Do incremental search forward for regular expression. -Like ordinary incremental search except that your input -is treated as a regexp. See \\[isearch-forward] for more info." - (interactive) - (isearch t t)) -(define-key esc-map "\C-s" 'isearch-forward-regexp) - -(defun isearch-backward () - "Do incremental search backward. -See \\[isearch-forward] for more information." - (interactive) - (isearch nil)) -(define-key global-map "\C-r" 'isearch-backward) - -(defun isearch-backward-regexp () - "Do incremental search backward for regular expression. -Like ordinary incremental search except that your input -is treated as a regexp. See \\[isearch-forward] for more info." - (interactive) - (isearch nil t)) -(define-key esc-map "\C-r" 'isearch-backward-regexp) - - -;; This function does all the work of incremental search. -;; The functions attached to ^R and ^S are trivial, -;; merely calling this one, but they are always loaded by default -;; whereas this file can optionally be autoloadable. -;; This is the only entry point in this file. - -;; OP-FUN is a function to be called after each input character is processed. -;; (It is not called after characters that exit the search.) - -(defun isearch (forward &optional regexp op-fun) - (let ((search-string "") - (search-message "") - ;; List of previous states during this search. - (history nil) - ;; t means search is currently successful. - (success t) - ;; Set once the search has wrapped around the end of the buffer. - (wrapped nil) - ;; Nominal starting point for searching - ;; Usually this is the same as the opoint, - ;; but it is changed by wrapping - ;; and also by repeating the search. - (barrier (point)) - ;; Set temporarily when adding a character to a regexp - ;; enables it to match more rather than fewer places in the buffer. - liberalized - ;; Set temporarily by yanking text into the search string. - yank-flag - (invalid-regexp nil) - ;; non-nil means an explicit uppercase letter seen in the input - (uppercase-flag nil) - ;; Non-nil means start using a small window - ;; if the search moves outside what is currently on the frame. - (slow-terminal-mode (and (<= baud-rate search-slow-speed) - (> (window-height) - (* 4 search-slow-window-lines)))) - ;; t means a small window is currently in use. - (small-window nil) ;if t, using a small window - ;; These variables preserve information from the small window - ;; through exit from the save-window-excursion. - (found-point nil) - (found-start nil) - ;; Point is at one end of the last match. - ;; This variable records the other end of that match. - (other-end nil) - ;; Value of point at start of search, - ;; for moving the cursor back on quitting. - (opoint (point)) - (inhibit-quit t) ;Prevent ^G from quitting, so we can read it. - ;; The frame we're working on; if this changes, we exit isearch. - (frame (if (fboundp 'selected-frame) (selected-frame)))) - - (isearch-push-state) - (save-window-excursion - (catch 'search-done - (while t - (or (and (numberp unread-command-char) (>= unread-command-char 0)) - (progn - (or (input-pending-p) - (isearch-message)) - (if (and slow-terminal-mode - (not (or small-window (pos-visible-in-window-p)))) - (progn - (setq small-window t) - (setq found-point (point)) - (move-to-window-line 0) - (let ((window-min-height 1)) - (split-window nil (if (< search-slow-window-lines 0) - (1+ (- search-slow-window-lines)) - (- (window-height) - (1+ search-slow-window-lines))))) - (if (< search-slow-window-lines 0) - (progn (vertical-motion (- 1 search-slow-window-lines)) - (set-window-start (next-window) (point)) - (set-window-hscroll (next-window) - (window-hscroll)) - (set-window-hscroll (selected-window) 0)) - (other-window 1)) - (goto-char found-point))))) - (let ((char (if quit-flag - ?\C-g - (read-event)))) - (setq quit-flag nil liberalized nil yank-flag nil) - (cond ((and (or (not (integerp char)) - (and (>= char 128) - (not (= char search-ring-advance-char)) - (not (= char search-ring-retreat-char)))) - search-exit-option) - (setq unread-command-char char) - (throw 'search-done t)) - - ;; If the user switches to a different frame, exit. - ((not (eq frame last-event-frame)) - (setq unread-command-char char) - (throw 'search-done t)) - - ((eq char search-exit-char) - ;; RET means exit search normally. - ;; Except, if first thing typed, it means do nonincremental - (if (= 0 (length search-string)) - (nonincremental-search forward regexp)) - (throw 'search-done t)) - ((= char ?\C-g) - ;; ^G means the user tried to quit. - (ding) - (discard-input) - (if success - ;; If search is successful, move back to starting point - ;; and really do quit. - (progn (goto-char opoint) - (signal 'quit nil)) - ;; If search is failing, rub out until it is once more - ;; successful. - (while (not success) (isearch-pop)))) - ((or (eq char search-repeat-char) - (eq char search-reverse-char)) - (if (eq forward (eq char search-repeat-char)) - ;; C-s in forward or C-r in reverse. - (if (equal search-string "") - ;; If search string is empty, use last one. - (isearch-get-string-from-ring) - ;; If already have what to search for, repeat it. - (or success - (progn (goto-char (if forward (point-min) (point-max))) - (setq wrapped t)))) - ;; C-s in reverse or C-r in forward, change direction. - (setq forward (not forward))) - (setq barrier (point)) ; For subsequent \| if regexp. - (setq success t) - (or (equal search-string "") - (progn - ;; If repeating a search that found an empty string, - ;; ensure we advance. Test history to make sure we - ;; actually have done a search already; otherwise, - ;; the match data will be random. - (if (and (cdr history) - (= (match-end 0) (match-beginning 0))) - (forward-char (if forward 1 -1))) - (isearch-search))) - (isearch-push-state)) - ((= char search-delete-char) - ;; Rubout means discard last input item and move point - ;; back. If buffer is empty, just beep. - (if (null (cdr history)) - (ding) - (isearch-pop))) - ((= char search-ring-advance-char) - (isearch-pop) - (if regexp - (let ((length (length regexp-search-ring))) - (if (zerop length) - () - (setq regexp-search-ring-yank-pointer - (nthcdr (% (+ 1 (- length (length regexp-search-ring-yank-pointer))) - length) - regexp-search-ring)) - (isearch-get-string-from-ring))) - (let ((length (length search-ring))) - (if (zerop length) - () - (setq search-ring-yank-pointer - (nthcdr (% (+ 1 (- length (length search-ring-yank-pointer))) - length) - search-ring)) - (isearch-get-string-from-ring)))) - (isearch-push-state) - (isearch-search)) - ((= char search-ring-retreat-char) - (isearch-pop) - (if regexp - (let ((length (length regexp-search-ring))) - (if (zerop length) - () - (setq regexp-search-ring-yank-pointer - (nthcdr (% (+ (- length (length regexp-search-ring-yank-pointer)) - (1- length)) - length) - regexp-search-ring)) - (isearch-get-string-from-ring))) - (let ((length (length search-ring))) - (if (zerop length) - () - (setq search-ring-yank-pointer - (nthcdr (% (+ (- length (length search-ring-yank-pointer)) - (1- length)) - length) - search-ring)) - (isearch-get-string-from-ring)))) - (isearch-push-state) - (isearch-search)) - (t - (cond ((or (eq char search-yank-word-char) - (eq char search-yank-line-char)) - ;; ^W means gobble next word from buffer. - ;; ^Y means gobble rest of line from buffer. - (let ((word (save-excursion - (and (not forward) other-end - (goto-char other-end)) - (buffer-substring - (point) - (save-excursion - (if (eq char search-yank-line-char) - (end-of-line) - (forward-word 1)) - (point)))))) - (if regexp - (setq word (regexp-quote word))) - (setq search-string (concat search-string word) - search-message - (concat search-message - (mapconcat 'text-char-description - word "")) - ;; Don't move cursor in reverse search. - yank-flag t))) - ;; Any other control char => - ;; unread it and exit the search normally. - ((and search-exit-option - (/= char search-quote-char) - (or (>= char ?\177) - (and (< char ? ) - (/= char ?\t) - (/= char ?\n)))) - (setq unread-command-char char) - (throw 'search-done t)) - (t - ;; Any other character => add it to the - ;; search string and search. - (cond ((= char search-quote-char) - (setq char (read-quoted-char - (isearch-message t)))) - ((= char ?\r) - ;; RET translates to newline. - (setq char ?\n))) - (setq search-string (concat search-string - (char-to-string char)) - search-message (concat search-message - (text-char-description char)) - uppercase-flag (or uppercase-flag - (not (= char (downcase char))))))) - (if (and (not success) - ;; unsuccessful regexp search may become - ;; successful by addition of characters which - ;; make search-string valid - (not regexp)) - nil - ;; Check for chars that can make a regexp more liberal. - ;; They can make a regexp match sooner - ;; or make it succeed instead of failing. - ;; So go back to place last successful search started - ;; or to the last ^S/^R (barrier), whichever is nearer. - (and regexp history - (cond ((and (memq char '(?* ??)) - ;; Don't treat *, ? as special - ;; within [] or after \. - (not (nth 6 (car history)))) - (setq liberalized t) - ;; This used to use element 2 - ;; in a reverse search, but it seems that 5 - ;; (which is the end of the old match) - ;; is better in that case too. - (let ((cs (nth 5 ; old other-end. - (car (cdr history))))) - ;; (car history) is after last search; - ;; (car (cdr history)) is from before it. - (setq cs (or cs barrier)) - (goto-char - (if forward - (max cs barrier) - (min cs barrier))))) - ((eq char ?\|) - (setq liberalized t) - (goto-char barrier)))) - ;; Turn off case-sensitivity if string requests it. - (let ((case-fold-search - (and case-fold-search - (not (and uppercase-flag - search-upper-case))))) - ;; In reverse search, adding stuff at - ;; the end may cause zero or many more chars to be - ;; matched, in the string following point. - ;; Allow all those possibilities without moving point as - ;; long as the match does not extend past search origin. - (if (and (not forward) (not liberalized) - (condition-case () - (looking-at (if regexp search-string - (regexp-quote search-string))) - (error nil)) - (or yank-flag - ;; Used to have (min opoint barrier) - ;; instead of barrier. - ;; This lost when wrapping. - (<= (match-end 0) barrier))) - (setq success t invalid-regexp nil - other-end (match-end 0)) - ;; Not regexp, not reverse, or no match at point. - (if (and other-end (not liberalized)) - (goto-char (if forward other-end - ;; Used to have opoint inside the min. - ;; This lost when wrapping. - (min barrier (1+ other-end))))) - (isearch-search)))) - (isearch-push-state)))) - (if op-fun (funcall op-fun)))) - (setq found-start (window-start (selected-window))) - (setq found-point (point))) - (if (> (length search-string) 0) - (if (and regexp (not (member search-string regexp-search-ring))) - (progn - (setq regexp-search-ring (cons (cons search-string uppercase-flag) - regexp-search-ring) - regexp-search-ring-yank-pointer regexp-search-ring) - (if (> (length regexp-search-ring) search-ring-max) - (setcdr (nthcdr (1- search-ring-max) regexp-search-ring) nil))) - (if (not (member search-string search-ring)) - (progn - (setq search-ring (cons (cons search-string uppercase-flag) - search-ring) - search-ring-yank-pointer search-ring) - (if (> (length search-ring) search-ring-max) - (setcdr (nthcdr (1- search-ring-max) search-ring) nil)))))) - ;; If we displayed a single-line window, set point in this window. - (if small-window - (goto-char found-point)) - ;; If there was movement, mark the starting position. - ;; Maybe should test difference between and set mark iff > threshold. - (if (/= (point) opoint) - (push-mark opoint) - (message "")) - (or small-window - ;; Exiting the save-window-excursion clobbers this; restore it. - (set-window-start (selected-window) found-start t)))) - -(defun isearch-message (&optional c-q-hack ellipsis) - ;; If about to search, and previous search regexp was invalid, - ;; check that it still is. If it is valid now, - ;; let the message we display while searching say that it is valid. - (and invalid-regexp ellipsis - (condition-case () - (progn (re-search-forward search-string (point) t) - (setq invalid-regexp nil)) - (error nil))) - ;; If currently failing, display no ellipsis. - (or success (setq ellipsis nil)) - (let ((m (concat (if success "" "failing ") - (if wrapped "wrapped ") - (if (or (not case-fold-search) - (and uppercase-flag search-upper-case)) - "case-sensitive ") - (if regexp "regexp " "") - "I-search" - (if forward ": " " backward: ") - search-message - (if c-q-hack "^Q" "") - (if invalid-regexp - (concat " [" invalid-regexp "]") - "")))) - (aset m 0 (upcase (aref m 0))) - (let ((cursor-in-echo-area ellipsis)) - (if c-q-hack m (message "%s" m))))) - -;; Get the search string from the "front" of the ring of previous searches. -(defun isearch-get-string-from-ring () - (let ((elt (car (if regexp - (or regexp-search-ring-yank-pointer regexp-search-ring) - (or search-ring-yank-pointer search-ring))))) - ;; ELT describes the most recent search or where we have rotated the ring. - (if elt - (setq search-string (car elt) - uppercase-flag (cdr elt)) - (setq search-string "" uppercase-flag nil))) - ;; Let's give this one the benefit of the doubt. - (setq invalid-regexp nil) - (setq search-message (mapconcat 'text-char-description search-string ""))) - -(defun isearch-pop () - (setq history (cdr history)) - (let ((cmd (car history))) - (setq search-string (car cmd) - search-message (car (cdr cmd)) - success (nth 3 cmd) - forward (nth 4 cmd) - other-end (nth 5 cmd) - invalid-regexp (nth 6 cmd) - wrapped (nth 7 cmd) - barrier (nth 8 cmd) - uppercase-flag (nth 9 cmd)) - (goto-char (car (cdr (cdr cmd)))))) - -(defun isearch-push-state () - (setq history (cons (list search-string search-message (point) - success forward other-end invalid-regexp - wrapped barrier uppercase-flag) - history))) - -(defun isearch-search () - (let ((case-fold-search - (and case-fold-search - (not (and uppercase-flag - search-upper-case))))) - (isearch-message nil t) - (condition-case lossage - (let ((inhibit-quit nil)) - (if regexp (setq invalid-regexp nil)) - (setq success - (funcall - (if regexp - (if forward 're-search-forward 're-search-backward) - (if forward 'search-forward 'search-backward)) - search-string nil t)) - (if success - (setq other-end - (if forward (match-beginning 0) (match-end 0))))) - (quit (setq unread-command-char ?\C-g) - (setq success nil)) - (invalid-regexp (setq invalid-regexp (car (cdr lossage))) - (if (string-match "\\`Premature \\|\\`Unmatched \\|\\`Invalid " - invalid-regexp) - (setq invalid-regexp "incomplete input")))) - (if success - nil - ;; Ding if failed this time after succeeding last time. - (and (nth 3 (car history)) - (ding)) - (goto-char (nth 2 (car history)))))) - -;; This is called from incremental-search -;; if the first input character is the exit character. -;; The interactive-arg-reader uses free variables `forward' and `regexp' -;; which are bound by `incremental-search'. - -;; We store the search string in `search-string' -;; which has been bound already by `incremental-search' -;; so that, when we exit, it is copied into `search-last-string'. - -(defun nonincremental-search (forward regexp) - (let (message char function string inhibit-quit) - (let ((cursor-in-echo-area t)) - ;; Prompt assuming not word search, - (setq message (if regexp - (if forward "Regexp search: " - "Regexp search backward: ") - (if forward "Search: " "Search backward: "))) - (message "%s" message) - ;; Read 1 char and switch to word search if it is ^W. - (setq char (read-event))) - (if (and (numberp char) (eq char search-yank-word-char)) - (setq message (if forward "Word search: " "Word search backward: ")) - ;; Otherwise let that 1 char be part of the search string. - (setq unread-command-char char)) - (setq function - (if (eq char search-yank-word-char) - (if forward 'word-search-forward 'word-search-backward) - (if regexp - (if forward 're-search-forward 're-search-backward) - (if forward 'search-forward 'search-backward)))) - ;; Read the search string with corrected prompt. - (setq string (read-string message)) - ;; Empty means use default. - (if (= 0 (length string)) - (setq string search-last-string) - ;; Set last search string now so it is set even if we fail. - (setq search-last-string string)) - ;; Since we used the minibuffer, we should be available for redo. - (setq command-history (cons (list function string) command-history)) - ;; Go ahead and search. - (funcall function string))) - -;;; isearch.el ends here
--- a/lisp/=iso8859-1.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -;;; iso8859-1.el --- set up case-conversion and syntax tables for ISO 8859/1 - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Howard Gayle -;; Maintainer: FSF -;; Keywords: i18n - -;; 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: - -;; Written by Howard Gayle. See case-table.el for details. - -;;; Code: - -(require 'case-table) - -(let ((table (car (standard-case-table)))) - (set-case-syntax 160 " " table) ; NBSP (no-break space) - (set-case-syntax 161 "." table) ; inverted exclamation mark - (set-case-syntax 162 "w" table) ; cent sign - (set-case-syntax 163 "w" table) ; pound sign - (set-case-syntax 164 "w" table) ; general currency sign - (set-case-syntax 165 "w" table) ; yen sign - (set-case-syntax 166 "_" table) ; broken vertical line - (set-case-syntax 167 "w" table) ; section sign - (set-case-syntax 168 "w" table) ; diaeresis - (set-case-syntax 169 "_" table) ; copyright sign - (set-case-syntax 170 "w" table) ; ordinal indicator, feminine - (set-case-syntax-delims 171 187 table) ; angle quotation marks - (set-case-syntax 172 "_" table) ; not sign - (set-case-syntax 173 "_" table) ; soft hyphen - (set-case-syntax 174 "_" table) ; registered sign - (set-case-syntax 175 "w" table) ; macron - (set-case-syntax 176 "_" table) ; degree sign - (set-case-syntax 177 "_" table) ; plus or minus sign - (set-case-syntax 178 "w" table) ; superscript two - (set-case-syntax 179 "w" table) ; superscript three - (set-case-syntax 180 "w" table) ; acute accent - (set-case-syntax 181 "_" table) ; micro sign - (set-case-syntax 182 "w" table) ; pilcrow - (set-case-syntax 183 "_" table) ; middle dot - (set-case-syntax 184 "w" table) ; cedilla - (set-case-syntax 185 "w" table) ; superscript one - (set-case-syntax 186 "w" table) ; ordinal indicator, masculine - ;; 187 ; See 171 above. - (set-case-syntax 188 "_" table) ; fraction one-quarter - (set-case-syntax 189 "_" table) ; fraction one-half - (set-case-syntax 190 "_" table) ; fraction three-quarters - (set-case-syntax 191 "." table) ; inverted question mark - (set-case-syntax-pair 192 224 table) ; A with grave accent - (set-case-syntax-pair 193 225 table) ; A with acute accent - (set-case-syntax-pair 194 226 table) ; A with circumflex accent - (set-case-syntax-pair 195 227 table) ; A with tilde - (set-case-syntax-pair 196 228 table) ; A with diaeresis or umlaut mark - (set-case-syntax-pair 197 229 table) ; A with ring - (set-case-syntax-pair 198 230 table) ; AE diphthong - (set-case-syntax-pair 199 231 table) ; C with cedilla - (set-case-syntax-pair 200 232 table) ; E with grave accent - (set-case-syntax-pair 201 233 table) ; E with acute accent - (set-case-syntax-pair 202 234 table) ; E with circumflex accent - (set-case-syntax-pair 203 235 table) ; E with diaeresis or umlaut mark - (set-case-syntax-pair 204 236 table) ; I with grave accent - (set-case-syntax-pair 205 237 table) ; I with acute accent - (set-case-syntax-pair 206 238 table) ; I with circumflex accent - (set-case-syntax-pair 207 239 table) ; I with diaeresis or umlaut mark - (set-case-syntax-pair 208 240 table) ; D with stroke, Icelandic eth - (set-case-syntax-pair 209 241 table) ; N with tilde - (set-case-syntax-pair 210 242 table) ; O with grave accent - (set-case-syntax-pair 211 243 table) ; O with acute accent - (set-case-syntax-pair 212 244 table) ; O with circumflex accent - (set-case-syntax-pair 213 245 table) ; O with tilde - (set-case-syntax-pair 214 246 table) ; O with diaeresis or umlaut mark - (set-case-syntax 215 "_" table) ; multiplication sign - (set-case-syntax-pair 216 248 table) ; O with slash - (set-case-syntax-pair 217 249 table) ; U with grave accent - (set-case-syntax-pair 218 250 table) ; U with acute accent - (set-case-syntax-pair 219 251 table) ; U with circumflex accent - (set-case-syntax-pair 220 252 table) ; U with diaeresis or umlaut mark - (set-case-syntax-pair 221 253 table) ; Y with acute accent - (set-case-syntax-pair 222 254 table) ; thorn, Icelandic - (set-case-syntax 223 "w" table) ; small sharp s, German - (set-case-syntax 247 "_" table) ; division sign - (set-case-syntax 255 "w" table) ; small y with diaeresis or umlaut mark - (set-standard-case-table (list table))) - -(provide 'iso8859-1) - -;;; iso8859-1.el ends here
--- a/lisp/=libc.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,254 +0,0 @@ -;;; libc.el -- lookup C symbols in the GNU C Library Reference Manual. - -;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - -;;; Author: Ralph Schleicher <rs@purple.UL.BaWue.DE> -;;; Keywords: local c info - -;; 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 code has a long history. It started as a minor -;; mode for C mode. This era ended with the release of version 2 -;; of the GNU C Library in 1997. The code was therefore rewritten -;; more or less from scratch so that all lookups are performed via -;; indices. Not finding an existing symbol in an index means that -;; there is an error in the manual. Long missed features like a -;; separate input history, symbol name completion in the mini-buffer, -;; highlighting of looked up symbol names in the Info buffer, and -;; implicitly prepending `struct', `union' or `enum' to data types -;; were added in this phase too. - -;;; Code: - -(require 'info) - - -(defvar libc-info-file-name "libc" - "Basename of the Info file of the GNU C Library Reference Manual.") - -(defvar libc-highlight-face 'highlight - "*Face for highlighting looked up symbol names in the Info buffer. -`nil' disables highlighting.") - -(defvar libc-highlight-overlay nil - "Overlay object used for highlighting.") - -(defconst libc-symbol-completions nil - "Alist of documented C symbols.") - -(defconst libc-file-completions nil - "Alist of documented programs or files.") - -(defvar libc-history nil - "History of previous input lines.") - -;;;###autoload -(defun libc-describe-symbol (symbol-name) - "Display the documentation of a C symbol in another window. -SYMBOL-NAME must be documented in the GNU C Library Reference Manual. - -If called interactively, SYMBOL-NAME will be read from the mini-buffer. -Optional prefix argument means insert the default symbol (if any) into -the mini-buffer so that it can be edited. The default symbol is the -one found at point. - -If SYMBOL-NAME is a public function, variable, or data type of the GNU -C Library but `libc-describe-symbol' fails to display it's documentation, -then you have found a bug in the manual. Please report that to the mail -address `bug-glibc-manual@prep.ai.mit.edu' so that it can be fixed." - (interactive - (let* ((completion-ignore-case nil) - (enable-recursive-minibuffers t) - (symbol (libc-symbol-at-point)) - (value (completing-read - (if symbol - (format "Describe symbol (default %s): " symbol) - (format "Describe symbol: ")) - libc-symbol-completions nil nil - (and current-prefix-arg symbol) 'libc-history))) - (list (if (equal value "") symbol value)))) - (or (assoc symbol-name libc-symbol-completions) - (error "Not documented as a C symbol: %s" (or symbol-name ""))) - (or (libc-lookup-function symbol-name) - (libc-lookup-variable symbol-name) - (libc-lookup-type symbol-name))) - -;;;###autoload -(defun libc-describe-file (file-name) - "Display the documentation of a program or file in another window. -FILE-NAME must be documented in the GNU C Library Reference Manual." - (interactive - (let* ((completion-ignore-case nil) - (enable-recursive-minibuffers t)) - (list (completing-read - "Describe program or file: " - libc-file-completions nil nil nil 'libc-history)))) - (or (assoc file-name libc-file-completions) - (error "Not documented as a program or file: %s" (or file-name ""))) - (libc-lookup-file file-name)) - -;;;###autoload -(defun libc-search (regexp &optional arg) - "Search in the GNU C Library Reference Manual for REGEXP. -Prefix argument means search should ignore case." - (interactive "sSearch `libc.info' for regexp: \nP") - (or (get-buffer "*info*") - (save-window-excursion - (info))) - (switch-to-buffer-other-window "*info*") - (Info-goto-node (concat "(" libc-info-file-name ")")) - (let ((case-fold-search arg)) - (Info-search regexp))) - - -(defun libc-make-completion-alist (info-nodes &optional regexp) - "Create a unique alist from all menu items in the Info nodes INFO-NODES -of the GNU C Reference Manual. - -Optional second argument REGEXP means include only menu items matching the -regular expression REGEXP." - (condition-case nil - (let (completions item) - (save-window-excursion - (info libc-info-file-name) - (while info-nodes - (Info-goto-node (car info-nodes)) - (goto-char (point-min)) - (and (search-forward "\n* Menu:" nil t) - (while (re-search-forward "\n\\* \\([^:\t\n]*\\):" nil t) - (setq item (buffer-substring - (match-beginning 1) (match-end 1))) - (and (not (assoc item completions)) - (if regexp (string-match regexp item) t) - (setq completions (cons (cons item nil) - completions))))) - (setq info-nodes (cdr info-nodes))) - (Info-directory)) - completions) - (error nil))) - -(defun libc-after-manual-update () - "This function must only be called after a new version of the -GNU C Library Reference Manual was installed on your system." - (setq libc-symbol-completions (libc-make-completion-alist - '("Function Index" - "Variable Index" - "Type Index")) - libc-file-completions (libc-make-completion-alist - '("File Index") "^[^ \t]+$"))) - -(or (and libc-symbol-completions - libc-file-completions) - (libc-after-manual-update)) - -(defun libc-symbol-at-point () - "Get the C symbol at point." - (condition-case nil - (save-excursion - (backward-sexp) - (let ((start (point)) - prefix name) - ;; Test for a leading `struct', `union', or `enum' keyword - ;; but ignore names like `foo_struct'. - (setq prefix (and (< (skip-chars-backward " \t\n") 0) - (< (skip-chars-backward "_a-zA-Z0-9") 0) - (looking-at "\\(struct\\|union\\|enum\\)\\s ") - (concat (buffer-substring - (match-beginning 1) (match-end 1)) - " "))) - (goto-char start) - (and (looking-at "[_a-zA-Z][_a-zA-Z0-9]*") - (setq name (buffer-substring - (match-beginning 0) (match-end 0)))) - ;; Caveat! Look forward if point is at `struct' etc. - (and (not prefix) - (or (string-equal name "struct") - (string-equal name "union") - (string-equal name "enum")) - (looking-at "[a-z]+\\s +\\([_a-zA-Z][_a-zA-Z0-9]*\\)") - (setq prefix (concat name " ") - name (buffer-substring - (match-beginning 1) (match-end 1)))) - (and (or prefix name) - (concat prefix name)))) - (error nil))) - -(defun libc-lookup-function (function) - (libc-search-index "Function Index" function - "^[ \t]+- \\(Function\\|Macro\\): .*\\<" "\\>")) - -(defun libc-lookup-variable (variable) - (libc-search-index "Variable Index" variable - "^[ \t]+- \\(Variable\\|Macro\\): .*\\<" "\\>")) - -(defun libc-lookup-type (data-type) - (libc-search-index "Type Index" data-type - "^[ \t]+- Data Type: \\<" "\\>")) - -(defun libc-lookup-file (file-name) - (libc-search-index "File Index" file-name)) - -(defun libc-search-index (index item &optional prefix suffix) - "Search ITEM in the Info index INDEX and go to that Info node. - -Value is ITEM or `nil' if an error occurs. - -If PREFIX and/or SUFFIX are non-`nil', then search the Info node for -the first occurrence of the regular expression `PREFIX ITEM SUFFIX' and -leave point at the beginning of the first line of the match. ITEM will -be highlighted with `libc-highlight-face' iff `libc-highlight-face' is -not `nil'." - (condition-case nil - (save-selected-window - (or (get-buffer "*info*") - (save-window-excursion - (info))) - (switch-to-buffer-other-window "*info*") - (Info-goto-node (concat "(" libc-info-file-name ")" index)) - (Info-menu item) - (if (or prefix suffix) - (let ((case-fold-search nil) - (buffer-read-only nil)) - (goto-char (point-min)) - (re-search-forward - (concat prefix (regexp-quote item) suffix)) - (goto-char (match-beginning 0)) - (and window-system libc-highlight-face - ;; Search again for ITEM so that the first - ;; occurence of ITEM will be highlighted. - (save-excursion - (re-search-forward (regexp-quote item)) - (let ((start (match-beginning 0)) - (end (match-end 0))) - (if (overlayp libc-highlight-overlay) - (move-overlay libc-highlight-overlay - start end (current-buffer)) - (setq libc-highlight-overlay - (make-overlay start end)))) - (overlay-put libc-highlight-overlay - 'face libc-highlight-face))) - (beginning-of-line))) - item) - (error nil))) - - -(provide 'libc) - -;;; libc.el ends here
--- a/lisp/=man.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -;;; man.el --- read in and display parts of Unix manual. - -;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: unix - -;; 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: - -;; This package provides an equivalent of the UNIX man(1) command within -;; Emacs. The single entry point is `manual-entry'. - -;;; Code: - -;;;###autoload -(defun manual-entry (topic &optional section) - "Display the Unix manual entry for TOPIC. -TOPIC is either the title of the entry, or has the form TITLE(SECTION) -where SECTION is the desired section of the manual, as in \"tty(4)\"." - (interactive "sManual entry (topic): ") - (if (= (length topic) 0) - (error "Must specify topic")) - (if (and (null section) - (string-match "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" topic)) - (setq section (substring topic (match-beginning 2) - (match-end 2)) - topic (substring topic (match-beginning 1) - (match-end 1)))) - (with-output-to-temp-buffer (concat "*" topic " Manual Entry*") - (buffer-disable-undo standard-output) - (save-excursion - (set-buffer standard-output) - (message "Looking for formatted entry for %s%s..." - topic (if section (concat "(" section ")") "")) - (let ((dirlist manual-formatted-dirlist) - (case-fold-search nil) - name) - (if (and section (or (file-exists-p - (setq name (concat manual-formatted-dir-prefix - (substring section 0 1) - "/" - topic "." section))) - (file-exists-p - (setq name (concat manual-formatted-dir-prefix - section - "/" - topic "." section))))) - (insert-man-file name) - (while dirlist - (let* ((dir (car dirlist)) - (name1 (concat dir "/" topic "." - (or section - (substring - dir - (1+ (or (string-match "\\.[^./]*$" dir) - -2)))))) - completions) - (if (file-exists-p name1) - (insert-man-file name1) - (condition-case () - (progn - (setq completions (file-name-all-completions - (concat topic "." (or section "")) - dir)) - (while completions - (insert-man-file (concat dir "/" (car completions))) - (setq completions (cdr completions)))) - (file-error nil))) - (goto-char (point-max))) - (setq dirlist (cdr dirlist))))) - - (if (= (buffer-size) 0) - (progn - (message "No formatted entry, invoking man %s%s..." - (if section (concat section " ") "") topic) - (if section - (call-process manual-program nil t nil section topic) - (call-process manual-program nil t nil topic)) - (if (< (buffer-size) 80) - (progn - (goto-char (point-min)) - (end-of-line) - (error (buffer-substring 1 (point))))))) - - (message "Cleaning manual entry for %s..." topic) - (nuke-nroff-bs) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (view-mode nil 'bury-buffer) - (message "")))) - -;; Hint: BS stands for more things than "back space" -(defun nuke-nroff-bs () - (interactive "*") - ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)" - ;; We expext to find a footer just before the header except at the beginning. - (goto-char (point-min)) - (while (re-search-forward "^ *\\([A-Za-z][-_.A-Za-z0-9]*([0-9A-Z]+)\\).*\\1$" nil t) - (let (start end) - ;; Put START and END around footer and header and garbage blank lines. - ;; Fixed line counts are risky, but allow us to preserve - ;; significant blank lines. - ;; These numbers are correct for MORE BSD, at least. - (setq start (save-excursion (forward-line -9) (point))) - (setq end (save-excursion (forward-line 3) (point))) - (delete-region start end))) - ;; Catch the final footer. - (goto-char (point-max)) - (delete-region (point) (save-excursion (forward-line -7) (point))) - - ;; Nuke underlining and overstriking (only by the same letter) - (goto-char (point-min)) - (while (search-forward "\b" nil t) - (let* ((preceding (char-after (- (point) 2))) - (following (following-char))) - (cond ((= preceding following) - ;; x\bx - (delete-char -2)) - ((and (= preceding ?o) (= following ?\+)) - ;; o\b+ - (delete-char -2)) - ((= preceding ?\_) - ;; _\b - (delete-char -2)) - ((= following ?\_) - ;; \b_ - (delete-region (1- (point)) (1+ (point))))))) - - ;; Zap ESC7, ESC8, and ESC9. - ;; This is for Sun man pages like "man 1 csh" - (goto-char (point-min)) - (while (re-search-forward "\e[789]" nil t) - (replace-match "")) - - ;; Convert o^H+ into o. - (goto-char (point-min)) - (while (re-search-forward "o\010\\+" nil t) - (replace-match "o")) - - ;; Nuke the dumb reformatting message - (goto-char (point-min)) - (while (re-search-forward "Reformatting page. Wait... done\n\n" nil t) - (replace-match "")) - - ;; Crunch blank lines - (goto-char (point-min)) - (while (re-search-forward "\n\n\n\n*" nil t) - (replace-match "\n\n")) - - ;; Nuke blanks lines at start. - (goto-char (point-min)) - (skip-chars-forward "\n") - (delete-region (point-min) (point))) - - -(defun insert-man-file (name) - ;; Insert manual file (unpacked as necessary) into buffer - (if (or (equal (substring name -2) ".Z") - (string-match "/cat[0-9][a-z]?\\.Z/" name)) - (call-process "zcat" name t nil) - (if (equal (substring name -2) ".z") - (call-process "pcat" nil t nil name) - (insert-file-contents name)))) - -;;; man.el ends here
--- a/lisp/=medit.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,123 +0,0 @@ -;;; medit.el --- front-end to the MEDIT package for editing MDL - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: languages - -;; 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: - -;; >> This package depends on two MDL packages: MEDIT and FORKS which -;; >> can be obtained from the public (network) library at mit-ajax. - -;;; Code: - -(require 'mim-mode) - -(defconst medit-zap-file (concat "/tmp/" (user-login-name) ".medit.mud") - "File name for data sent to MDL by Medit.") -(defconst medit-buffer "*MEDIT*" - "Name of buffer in which Medit accumulates data to send to MDL.") -(defconst medit-save-files t - "If non-nil, Medit offers to save files on return to MDL.") - -(defun medit-save-define () - "Mark the previous or surrounding toplevel object to be sent back to MDL." - (interactive) - (save-excursion - (beginning-of-DEFINE) - (let ((start (point))) - (forward-mim-object 1) - (append-to-buffer medit-buffer start (point)) - (goto-char start) - (message "%s" (buffer-substring start (progn (end-of-line) (point))))))) - -(defun medit-save-region (start end) - "Mark the current region to be sent to back to MDL." - (interactive "r") - (append-to-buffer medit-buffer start end) - (message "Current region saved for MDL.")) - -(defun medit-save-buffer () - "Mark the current buffer to be sent back to MDL." - (interactive) - (append-to-buffer medit-buffer (point-min) (point-max)) - (message "Current buffer saved for MDL.")) - -(defun medit-zap-define-to-mdl () - "Return to MDL with surrounding or previous toplevel MDL object." - (interactive) - (medit-save-define) - (medit-goto-mdl)) - -(defun medit-zap-region-mdl (start end) - "Return to MDL with current region." - (interactive) - (medit-save-region start end) - (medit-goto-mdl)) - -(defun medit-zap-buffer () - "Return to MDL with current buffer." - (interactive) - (medit-save-buffer) - (medit-goto-mdl)) - -(defun medit-goto-mdl () - "Return from Emacs to superior MDL, sending saved code. -Optionally, offers to save changed files." - (interactive) - (let ((buffer (get-buffer medit-buffer))) - (if buffer - (save-excursion - (set-buffer buffer) - (if (buffer-modified-p buffer) - (write-region (point-min) (point-max) medit-zap-file)) - (set-buffer-modified-p nil) - (erase-buffer))) - (if medit-save-files (save-some-buffers)) - ;; Note could handle parallel fork by giving argument "%xmdl". Then - ;; mdl would have to invoke with "%emacs". - (suspend-emacs))) - -(defconst medit-mode-map nil) -(if (not medit-mode-map) - (progn - (setq medit-mode-map (copy-keymap mim-mode-map)) - (define-key medit-mode-map "\e\z" 'medit-save-define) - (define-key medit-mode-map "\e\^z" 'medit-save-buffer) - (define-key medit-mode-map "\^xz" 'medit-goto-mdl) - (define-key medit-mode-map "\^xs" 'medit-zap-buffer))) - -(defconst medit-mode-hook (and (boundp 'mim-mode-hook) mim-mode-hook) "") -(setq mim-mode-hook '(lambda () (medit-mode))) - -(defun medit-mode (&optional state) - "Major mode for editing text and returning it to a superior MDL. -Like Mim mode, plus these special commands: -\\{medit-mode-map}" - (interactive) - (use-local-map medit-mode-map) - (run-hooks 'medit-mode-hook) - (setq major-mode 'medit-mode) - (setq mode-name "Medit")) - -(mim-mode) - -;;; medit.el ends here
--- a/lisp/=mh-e.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2933 +0,0 @@ -;;; mh-e.el --- GNU Emacs interface to the MH mail system - -;;; Copyright (C) 1985, 86, 87, 88, 90, 92, 93 Free Software Foundation - -(defconst mh-e-time-stamp "Time-stamp: <93/05/30 18:37:43 gildea>") - -;; Maintainer: Stephen Gildea <gildea@lcs.mit.edu> -;; Version: 3.8.2 -;; Keywords: mail - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but without any warranty. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; document "GNU Emacs copying permission notice". An exact copy -;; of the document is supposed to have been given to you along with -;; GNU Emacs so that you can know how you may redistribute it all. -;; It should be in a file named COPYING. Among other things, the -;; copyright notice and this notice must be preserved on all copies. - -;;; Commentary: - -;;; mh-e works with Emacs 18 or 19, and MH 5 or 6. - -;;; HOW TO USE: -;;; M-x mh-rmail to read mail. Type C-h m there for a list of commands. -;;; C-u M-x mh-rmail to visit any folder. -;;; M-x mh-smail to send mail. From within the mail reader, "m" works, too. -;;; Your .emacs might benefit from these bindings: -;;; (global-set-key "\C-xm" 'mh-smail) -;;; (global-set-key "\C-x4m" 'mh-smail-other-window) -;;; (global-set-key "\C-cr" 'mh-rmail) - -;;; MH (Message Handler) is a powerful mail reader. The MH newsgroup -;;; is comp.mail.mh; the mailing list is mh-users@ics.uci.edu (send to -;;; mh-users-request to be added). See the monthly Frequently Asked -;;; Questions posting there for information on getting MH. - -;;; NB. MH must have been compiled with the MHE compiler flag or several -;;; features necessary mh-e will be missing from MH commands, specifically -;;; the -build switch to repl and forw. - -;;; Original version for Gosling emacs by Brian Reid, Stanford, 1982. -;;; Modified by James Larus, BBN, July 1984 and UCB, 1984 & 1985. -;;; Rewritten for GNU Emacs, James Larus 1985. larus@ginger.berkeley.edu -;;; Modified by Stephen Gildea 1988. gildea@bbn.com -(defconst mh-e-RCS-id "$Header: /home/fsf/rms/e19/lisp/RCS/mh-e.el,v 1.15 1993/07/20 04:35:00 rms Exp rms $") - -;;; Code: - - - -;;; Constants: - -;;; Set for local environment: -;;;* These are now in paths.el. -;;;(defvar mh-progs "/usr/new/mh/" "Directory containing MH commands.") -;;;(defvar mh-lib "/usr/new/lib/mh/" "Directory of MH library.") - -(defvar mh-redist-full-contents nil - "Non-nil if the `dist' command needs whole letter for redistribution. -This is the case when `send' is compiled with the BERK option.") - - -;;; Hooks: - -(defvar mh-folder-mode-hook nil - "Invoked in `mh-folder mode' on a new folder.") - -(defvar mh-letter-mode-hook nil - "Invoked in `mh-letter-mode' on a new letter.") - -(defvar mh-compose-letter-function nil - "Invoked in `mh-compose-and-send-mail' on a draft letter. -It is passed three arguments: TO recipients, SUBJECT, and CC recipients.") - -(defvar mh-before-send-letter-hook nil - "Invoked at the beginning of the \\[mh-send-letter] command.") - -(defvar mh-inc-folder-hook nil - "Invoked after incorporating mail into a folder with \\[mh-inc-folder].") - -(defvar mh-before-quit-hook nil - "Invoked by \\[mh-quit] before quitting mh-e. See also mh-quit-hook") - -(defvar mh-quit-hook nil - "Invoked after quitting mh-e by \\[mh-quit]. See also mh-before-quit-hook") - - -(defvar mh-ins-string nil - "Temporarily set by `mh-insert-prefix' prior to running `mh-yank-hooks'.") - -(defvar mh-yank-hooks - '(lambda () - (save-excursion - (goto-char (point)) - (or (bolp) (forward-line 1)) - (while (< (point) (mark t)) - (insert mh-ins-string) - (forward-line 1)))) - "Hook to run citation function. -Expects POINT and MARK to be set to the region to cite.") - - -;;; Personal preferences: - -(defvar mh-clean-message-header nil - "*Non-nil means clean headers of messages that are displayed or inserted. -The variables `mh-visible-headers' and `mh-invisible-headers' control what -is removed.") - -(defvar mh-visible-headers nil - "*If non-nil, contains a regexp specifying the headers to keep when cleaning. -Only used if `mh-clean-message-header' is non-nil. Setting this variable -overrides `mh-invisible-headers'.") - -(defvar mhl-formfile nil - "*Name of format file to be used by mhl to show messages. -A value of T means use the default format file. -Nil means don't use mhl to format messages.") - -(defvar mh-lpr-command-format "lpr -p -J '%s'" - "*Format for Unix command that prints a message. -The string should be a Unix command line, with the string '%s' where -the job's name (folder and message number) should appear. The message text -is piped to this command.") - -(defvar mh-print-background nil - "*Print messages in the background if non-nil. -WARNING: do not delete the messages until printing is finished; -otherwise, your output may be truncated.") - -(defvar mh-summary-height 4 - "*Number of lines in summary window (including the mode line).") - -(defvar mh-recenter-summary-p nil - "*Recenter summary window when the show window is toggled off if non-nil.") - -(defvar mh-ins-buf-prefix "> " - "*String to put before each non-blank line of a yanked or inserted message. -Used when the message is inserted in an outgoing letter.") - -(defvar mh-do-not-confirm nil - "*Non-nil means do not prompt for confirmation before some commands. -Only affects certain innocuous commands.") - -(defvar mh-bury-show-buffer t - "*Non-nil means that the displayed show buffer for a folder is buried.") - -(defvar mh-delete-yanked-msg-window nil - "*Controls window display when a message is yanked by \\[mh-yank-cur-msg]. -If non-nil, yanking the current message into a draft letter deletes any -windows displaying the message.") - -(defvar mh-yank-from-start-of-msg t - "*Controls which part of a message is yanked by \\[mh-yank-cur-msg]. -If non-nil, include the entire message. If the symbol `body', then yank the -message minus the header. If nil, yank only the portion of the message -following the point. If the show buffer has a region, this variable is -ignored.") - -(defvar mh-reply-default-reply-to nil - "*Sets the person or persons to whom a reply will be sent. -If nil, prompt for recipient. If non-nil, then \\[mh-reply] will use this -value and it should be one of \"from\", \"to\", or \"cc\".") - -(defvar mh-recursive-folders nil - "*If non-nil, then commands which operate on folders do so recursively.") - -(defvar mh-unshar-default-directory "" - "*Default for directory name prompted for by mh-unshar-msg.") - -(defvar mh-signature-file-name "~/.signature" - "*Name of file containing the user's signature. -Inserted into message by \\<mh-letter-mode-map>\\[mh-insert-signature].") - - -;;; Parameterize mh-e to work with different scan formats. The defaults work -;;; with the standard MH scan listings. - -(defvar mh-cmd-note 4 - "Offset to insert notation.") - -(defvar mh-note-repl "-" - "String whose first character is used to notate replied to messages.") - -(defvar mh-note-forw "F" - "String whose first character is used to notate forwarded messages.") - -(defvar mh-note-dist "R" - "String whose first character is used to notate redistributed messages.") - -(defvar mh-good-msg-regexp "^....[^D^]" - "Regexp specifying the scan lines that are 'good' messages.") - -(defvar mh-deleted-msg-regexp "^....D" - "Regexp matching scan lines of deleted messages.") - -(defvar mh-refiled-msg-regexp "^....\\^" - "Regexp matching scan lines of refiled messages.") - -(defvar mh-valid-scan-line "^ *[0-9]" - "Regexp matching scan lines for messages (not error messages).") - -(defvar mh-msg-number-regexp "^ *\\([0-9]+\\)" - "Regexp to find the number of a message in a scan line. -The message's number must be surrounded with \\( \\)") - -(defvar mh-msg-search-regexp "^[^0-9]*%d[^0-9]" - "Format string containing a regexp matching the scan listing for a message. -The desired message's number will be an argument to format.") - -(defvar mh-flagged-scan-msg-regexp "^....\\D\\|^....\\^\\|^....\\+\\|^.....%" - "Regexp matching flagged scan lines. -Matches lines marked as deleted, refiled, in a sequence, or the cur message.") - -(defvar mh-cur-scan-msg-regexp "^....\\+" - "Regexp matching scan line for the cur message.") - -(defvar mh-show-buffer-mode-line-buffer-id "{%%b} %s/%d" - "Format string to produce `mode-line-buffer-id' for show buffers. -First argument is folder name. Second is message number.") - -(defvar mh-partial-folder-mode-line-annotation "select" - "Annotation when displaying part of a folder. -The string is displayed after the folder's name. NIL for no annotation.") - - -;;; Real constants: - -(defvar mh-invisible-headers - "^Received: \\|^Message-Id: \\|^Remailed-\\|^Via: \\|^Mail-from: \\|^Return-Path: \\|^In-Reply-To: \\|^Resent-" - "Regexp matching lines in a message header that are not to be shown. -If `mh-visible-headers' is non-nil, it is used instead to specify what -to keep.") - -(defvar mh-rejected-letter-start - (concat "^ ----- Unsent message follows -----$" ;from mail system - "\\|^------- Unsent Draft$" ;from MH itself - "\\|^ --- The unsent message follows ---$") ;from AIX mail system - "Regexp specifying the beginning of the wrapper around a returned letter. -This wrapper is generated by the mail system when rejecting a letter.") - -(defvar mh-to-field-choices '((?t . "To:") (?s . "Subject:") (?c . "Cc:") - (?b . "Bcc:") (?f . "Fcc:")) - "A-list of (character . field name) strings for mh-to-field.") - - -;;; Global variables: - -(defvar mh-user-path "" - "User's mail folder.") - -(defvar mh-last-destination nil - "Destination of last refile or write command.") - -(defvar mh-folder-mode-map (make-keymap) - "Keymap for MH folders.") - -(defvar mh-letter-mode-map (copy-keymap text-mode-map) - "Keymap for composing mail.") - -(defvar mh-pick-mode-map (make-sparse-keymap) - "Keymap for searching folder.") - -(defvar mh-searching-folder nil - "Folder this pick is searching.") - -(defvar mh-letter-mode-syntax-table nil - "Syntax table used while in mh-e letter mode.") - -(if mh-letter-mode-syntax-table - () - (setq mh-letter-mode-syntax-table - (make-syntax-table text-mode-syntax-table)) - (set-syntax-table mh-letter-mode-syntax-table) - (modify-syntax-entry ?% "." mh-letter-mode-syntax-table)) - -(defvar mh-folder-list nil - "List of folder names for completion.") - -(defvar mh-draft-folder nil - "Name of folder containing draft messages. -NIL means do not use draft folder.") - -(defvar mh-unseen-seq nil - "Name of the unseen sequence.") - -(defvar mh-previous-window-config nil - "Window configuration before mh-e command.") - -(defvar mh-previous-seq nil - "Name of the sequence to which a message was last added.") - - -;;; Macros and generic functions: - -(defmacro mh-push (v l) - (list 'setq l (list 'cons v l))) - - -(defmacro mh-when (pred &rest body) - (list 'cond (cons pred body))) - - -(defmacro with-mh-folder-updating (save-modification-flag-p &rest body) - ;; Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG-P) &body BODY). - ;; Execute BODY, which can modify the folder buffer without having to - ;; worry about file locking or the read-only flag, and return its result. - ;; If SAVE-MODIFICATION-FLAG-P is non-nil, the buffer's modification - ;; flag is unchanged, otherwise it is cleared. - (setq save-modification-flag-p (car save-modification-flag-p)) ; CL style - (` (let ((folder-updating-mod-flag (buffer-modified-p))) - (prog1 - (let ((buffer-read-only nil) - (buffer-file-name nil)) ; don't let the buffer get locked - (,@ body)) - (, (if save-modification-flag-p - '(mh-set-folder-modified-p folder-updating-mod-flag) - '(mh-set-folder-modified-p nil))))))) - - -(defun mh-mapc (func list) - (while list - (funcall func (car list)) - (setq list (cdr list)))) - - - -;;; Entry points: - -;;;###autoload -(defun mh-rmail (&optional arg) - "Inc(orporate) new mail (no arg) or scan a MH mail box (arg given). -This front end uses the MH mail system, which uses different conventions -from the usual mail system." - (interactive "P") - (mh-find-path) - (if arg - (call-interactively 'mh-visit-folder) - (mh-inc-folder))) - - -;;;###autoload -(defun mh-smail () - "Compose and send mail with the MH mail system." - (interactive) - (mh-find-path) - (call-interactively 'mh-send)) - - -(defun mh-smail-other-window () - "Compose and send mail in other window with the MH mail system." - (interactive) - (mh-find-path) - (call-interactively 'mh-send-other-window)) - - - -;;; User executable mh-e commands: - -(defun mh-burst-digest () - "Burst apart the current message, which should be a digest. -The message is replaced by its table of contents and the letters from the -digest are inserted into the folder after that message." - (interactive) - (let ((digest (mh-get-msg-num t))) - (mh-process-or-undo-commands mh-current-folder) - (mh-set-folder-modified-p t) ; lock folder while bursting - (message "Bursting digest...") - (mh-exec-cmd "burst" mh-current-folder digest "-inplace") - (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num)) - (message "Bursting digest...done"))) - - -(defun mh-copy-msg (prefix-provided msg-or-seq dest) - "Copy specified MESSAGE(s) to another FOLDER without deleting them. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Copy" t) - (mh-get-msg-num t)) - (mh-prompt-for-folder "Copy to" "" t))) - (mh-exec-cmd "refile" msg-or-seq "-link" "-src" mh-current-folder dest) - (if prefix-provided - (mh-notate-seq msg-or-seq ?C mh-cmd-note) - (mh-notate msg-or-seq ?C mh-cmd-note))) - - -(defun mh-delete-msg (msg-or-seq) - "Mark the specified MESSAGE(s) for subsequent deletion and move to the next. -Default is the displayed message. If optional prefix argument is -given then prompt for the message sequence." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)))) - (if (numberp msg-or-seq) - (mh-delete-a-msg msg-or-seq) - (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq)) - (mh-next-msg)) - - -(defun mh-delete-msg-no-motion (msg-or-seq) - "Mark the specified MESSAGE(s) for subsequent deletion. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)))) - (if (numberp msg-or-seq) - (mh-delete-a-msg msg-or-seq) - (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq))) - - -(defun mh-delete-msg-from-seq (prefix-provided msg-or-seq &optional from-seq) - "Delete MESSAGE (default: displayed message) from SEQUENCE. -If optional prefix argument provided, then delete all messages -from a sequence." - (interactive (let ((argp current-prefix-arg)) - (list argp - (if argp - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)) - (if (not argp) - (mh-read-seq-default "Delete from" t))))) - (if prefix-provided - (mh-remove-seq msg-or-seq) - (mh-remove-msg-from-seq msg-or-seq from-seq))) - - -(defun mh-edit-again (msg) - "Clean-up a draft or a message previously sent and make it resendable." - (interactive (list (mh-get-msg-num t))) - (let* ((from-folder mh-current-folder) - (config (current-window-configuration)) - (draft - (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) - (pop-to-buffer (find-file-noselect (mh-msg-filename msg)) t) - (rename-buffer (format "draft-%d" msg)) - (buffer-name)) - (t - (mh-read-draft "clean-up" (mh-msg-filename msg) nil))))) - (mh-clean-msg-header (point-min) - "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Delivery-Date:" - nil) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil - config))) - - -(defun mh-execute-commands () - "Process outstanding delete and refile requests." - (interactive) - (if mh-narrowed-to-seq (mh-widen)) - (mh-process-commands mh-current-folder) - (mh-set-scan-mode) - (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency - (mh-make-folder-mode-line) - t) ; return t for write-file-hooks - - -(defun mh-extract-rejected-mail (msg) - "Extract a letter returned by the mail system and make it resendable. -Default is the displayed message." - (interactive (list (mh-get-msg-num t))) - (let ((from-folder mh-current-folder) - (config (current-window-configuration)) - (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil))) - (goto-char (point-min)) - (cond ((re-search-forward mh-rejected-letter-start nil t) - (forward-char 1) - (delete-region (point-min) (point)) - (mh-clean-msg-header (point-min) - "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Return-Path:" - nil)) - (t - (message "Does not appear to be a rejected letter."))) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (mh-compose-and-send-mail draft "" from-folder msg (mh-get-field "To") - (mh-get-field "From") (mh-get-field "cc") - nil nil config))) - - -(defun mh-first-msg () - "Move to the first message." - (interactive) - (goto-char (point-min))) - - -(defun mh-forward (prefix-provided msg-or-seq to cc) - "Forward MESSAGE(s) (default: displayed message). -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Forward" t) - (mh-get-msg-num t)) - (read-string "To: ") - (read-string "Cc: "))) - (let* ((folder mh-current-folder) - (config (current-window-configuration)) - ;; forw always leaves file in "draft" since it doesn't have -draft - (draft-name (expand-file-name "draft" mh-user-path)) - (draft (cond ((or (not (file-exists-p draft-name)) - (y-or-n-p "The file 'draft' exists. Discard it? ")) - (mh-exec-cmd "forw" - "-build" mh-current-folder msg-or-seq) - (prog1 - (mh-read-draft "" draft-name t) - (mh-insert-fields "To:" to "Cc:" cc) - (set-buffer-modified-p nil))) - (t - (mh-read-draft "" draft-name nil))))) - (goto-char (point-min)) - (re-search-forward "^------- Forwarded Message") - (forward-line -1) - (narrow-to-region (point) (point-max)) - (let* ((subject (save-excursion (mh-get-field "From:"))) - (trim (string-match "<" subject)) - (forw-subject (save-excursion (mh-get-field "Subject:")))) - (if trim - (setq subject (substring subject 0 (1- trim)))) - (widen) - (save-excursion - (mh-insert-fields "Subject:" (format "[%s: %s]" subject forw-subject))) - (delete-other-windows) - (if prefix-provided - (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t) - (mh-add-msgs-to-seq msg-or-seq 'forwarded t)) - (mh-compose-and-send-mail draft "" folder msg-or-seq - to subject cc - mh-note-forw "Forwarded:" - config)))) - - -(defun mh-goto-msg (number &optional no-error-if-no-message dont-show) - "Position the cursor at message NUMBER. -Non-nil second argument means do not signal an error if message does not exist. -Non-nil third argument means not to show the message. -Return non-nil if cursor is at message." - (interactive "NGoto message: ") - (let ((cur-msg (mh-get-msg-num nil)) - (starting-place (point)) - (msg-pattern (mh-msg-search-pat number))) - (cond ((cond ((and cur-msg (= cur-msg number)) t) - ((and cur-msg - (< cur-msg number) - (re-search-forward msg-pattern nil t)) t) - ((and cur-msg - (> cur-msg number) - (re-search-backward msg-pattern nil t)) t) - (t ; Do thorough search of buffer - (goto-char (point-max)) - (re-search-backward msg-pattern nil t))) - (beginning-of-line) - (if (not dont-show) (mh-maybe-show number)) - t) - (t - (goto-char starting-place) - (if (not no-error-if-no-message) - (error "No message %d" number)) - nil)))) - - -(defun mh-inc-folder (&optional maildrop-name) - "Inc(orporate) new mail into +inbox. -Optional prefix argument specifies an alternate maildrop from the default. -If this is given, incorporate mail into the current folder, rather -than +inbox. Run `mh-inc-folder-hook' after incorporating new mail." - (interactive (list (if current-prefix-arg - (expand-file-name - (read-file-name "inc mail from file: " - mh-user-path))))) - (let ((config (current-window-configuration))) - (if (not maildrop-name) - (cond ((not (get-buffer "+inbox")) - (mh-make-folder "+inbox") - (setq mh-previous-window-config config)) - ((not (eq (current-buffer) (get-buffer "+inbox"))) - (switch-to-buffer "+inbox") - (setq mh-previous-window-config config))))) - (mh-get-new-mail maildrop-name) - (run-hooks 'mh-inc-folder-hook)) - - -(defun mh-kill-folder () - "Remove the current folder." - (interactive) - (if (or mh-do-not-confirm - (yes-or-no-p (format "Remove folder %s? " mh-current-folder))) - (let ((folder mh-current-folder)) - (mh-set-folder-modified-p t) ; lock folder to kill it - (mh-exec-cmd-daemon "rmf" folder) - (mh-remove-folder-from-folder-list folder) - (message "Folder %s removed" folder) - (mh-set-folder-modified-p nil) ; so kill-buffer doesn't complain - (if (get-buffer mh-show-buffer) - (kill-buffer mh-show-buffer)) - (kill-buffer folder)) - (message "Folder not removed"))) - - -(defun mh-last-msg () - "Move to the last message." - (interactive) - (goto-char (point-max)) - (while (and (not (bobp)) (looking-at "^$")) - (forward-line -1))) - - -(defun mh-list-folders () - "List mail folders." - (interactive) - (with-output-to-temp-buffer " *mh-temp*" - (save-excursion - (switch-to-buffer " *mh-temp*") - (erase-buffer) - (message "Listing folders...") - (mh-exec-cmd-output "folders" t (if mh-recursive-folders - "-recurse" - "-norecurse")) - (goto-char (point-min)) - (message "Listing folders...done")))) - - -(defun mh-msg-is-in-seq (msg) - "Display the sequences that contain MESSAGE (default: displayed message)." - (interactive (list (mh-get-msg-num t))) - (message "Message %d is in sequences: %s" - msg - (mapconcat 'concat - (mh-list-to-string (mh-seq-containing-msg msg)) - " "))) - - -(defun mh-narrow-to-seq (seq) - "Restrict display of this folder to just messages in a sequence. -Reads which sequence. Use \\[mh-widen] to undo this command." - (interactive (list (mh-read-seq "Narrow to" t))) - (let ((eob (point-max))) - (with-mh-folder-updating (t) - (cond ((mh-seq-to-msgs seq) - (mh-copy-seq-to-point seq eob) - (narrow-to-region eob (point-max)) - (mh-make-folder-mode-line (symbol-name seq)) - (mh-recenter nil) - (setq mh-narrowed-to-seq seq)) - (t - (error "No messages in sequence `%s'" (symbol-name seq))))))) - - -(defun mh-next-undeleted-msg (&optional arg) - "Move to next undeleted message in window." - (interactive "P") - (forward-line (prefix-numeric-value arg)) - (setq mh-next-direction 'forward) - (cond ((re-search-forward mh-good-msg-regexp nil 0 arg) - (beginning-of-line) - (mh-maybe-show)) - (t - (forward-line -1) - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) - - -(defun mh-pack-folder (range) - "Renumber the messages of a folder to be 1..n. -First, offer to execute any outstanding commands for the current folder. -If optional prefix argument provided, prompt for the range of messages -to display after packing. Otherwise, show the entire folder." - (interactive (list (if current-prefix-arg - (mh-read-msg-range - "Range to scan after packing [all]? ") - "all"))) - (mh-pack-folder-1 range) - (mh-goto-cur-msg) - (message "Packing folder...done")) - - -(defun mh-pipe-msg (prefix-provided command) - "Pipe the current message through the given shell COMMAND. -If optional prefix argument is provided, send the entire message. -Otherwise just send the message's body." - (interactive - (list current-prefix-arg (read-string "Shell command on message: "))) - (save-excursion - (mh-display-msg (mh-get-msg-num t) mh-current-folder) ;update show buffer - (goto-char (point-min)) - (if (not prefix-provided) (search-forward "\n\n")) - (shell-command-on-region (point) (point-max) command nil))) - - -(defun mh-refile-msg (prefix-provided msg-or-seq dest) - "Refile MESSAGE(s) (default: displayed message) in FOLDER. -If optional prefix argument provided, then prompt for message sequence." - (interactive - (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Refile" t) - (mh-get-msg-num t)) - (intern - (mh-prompt-for-folder "Destination" - (if (eq 'refile (car mh-last-destination)) - (symbol-name (cdr mh-last-destination)) - "") - t)))) - (setq mh-last-destination (cons 'refile dest)) - (if prefix-provided - (mh-map-to-seq-msgs 'mh-refile-a-msg msg-or-seq dest) - (mh-refile-a-msg msg-or-seq dest)) - (mh-next-msg)) - - -(defun mh-refile-or-write-again (msg) - "Re-execute the last refile or write command on the given MESSAGE. -Default is the displayed message. Use the same folder or file as the -previous refile or write command." - (interactive (list (mh-get-msg-num t))) - (if (null mh-last-destination) - (error "No previous refile or write")) - (cond ((eq (car mh-last-destination) 'refile) - (mh-refile-a-msg msg (cdr mh-last-destination)) - (message "Destination folder: %s" (cdr mh-last-destination))) - (t - (mh-write-msg-to-file msg (cdr mh-last-destination)) - (message "Destination: %s" (cdr mh-last-destination)))) - (mh-next-msg)) - - -(defun mh-reply (prefix-provided msg) - "Reply to a MESSAGE (default: displayed message). -If optional prefix argument provided, then include the message in the reply -using filter mhl.reply in your MH directory." - (interactive (list current-prefix-arg (mh-get-msg-num t))) - (let ((minibuffer-help-form - "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients")) - (let ((reply-to (or mh-reply-default-reply-to - (completing-read "Reply to whom: " - '(("from") ("to") ("cc") ("all")) - nil - t))) - (folder mh-current-folder) - (show-buffer mh-show-buffer) - (config (current-window-configuration))) - (message "Composing a reply...") - (cond ((or (equal reply-to "from") (equal reply-to "")) - (apply 'mh-exec-cmd - "repl" "-build" "-noquery" - "-nodraftfolder" mh-current-folder - msg - "-nocc" "all" - (if prefix-provided - (list "-filter" "mhl.reply")))) - ((equal reply-to "to") - (apply 'mh-exec-cmd - "repl" "-build" "-noquery" - "-nodraftfolder" mh-current-folder - msg - "-cc" "to" - (if prefix-provided - (list "-filter" "mhl.reply")))) - ((or (equal reply-to "cc") (equal reply-to "all")) - (apply 'mh-exec-cmd - "repl" "-build" "-noquery" - "-nodraftfolder" mh-current-folder - msg - "-cc" "all" "-nocc" "me" - (if prefix-provided - (list "-filter" "mhl.reply"))))) - - (let ((draft (mh-read-draft "reply" - (expand-file-name "reply" mh-user-path) - t))) - (delete-other-windows) - (set-buffer-modified-p nil) - - (let ((to (mh-get-field "To:")) - (subject (mh-get-field "Subject:")) - (cc (mh-get-field "Cc:"))) - (goto-char (point-min)) - (mh-goto-header-end 1) - (if (not prefix-provided) - (mh-display-msg msg folder)) - (mh-add-msgs-to-seq msg 'answered t) - (message "Composing a reply...done") - (mh-compose-and-send-mail draft "" folder msg to subject cc - mh-note-repl "Replied:" config)))))) - - -(defun mh-quit () - "Quit mh-e. -Start by running mh-before-quit-hook. Restore the previous window -configuration, if one exists. Finish by running mh-quit-hook." - (interactive) - (run-hooks 'mh-before-quit-hook) - (if mh-previous-window-config - (set-window-configuration mh-previous-window-config)) - (run-hooks 'mh-quit-hook)) - - -(defun mh-page-digest () - "Advance displayed message to next digested message." - (interactive) - (save-excursion - (mh-show-message-in-other-window) - ;; Go to top of screen (in case user moved point). - (move-to-window-line 0) - (let ((case-fold-search nil)) - ;; Search for blank line and then for From: - (mh-when (not (and (search-forward "\n\n" nil t) - (search-forward "From:" nil t))) - (other-window -1) - (error "No more messages"))) - ;; Go back to previous blank line, then forward to the first non-blank. - (search-backward "\n\n" nil t) - (forward-line 2) - (mh-recenter 0) - (other-window -1))) - - -(defun mh-page-digest-backwards () - "Back up displayed message to previous digested message." - (interactive) - (save-excursion - (mh-show-message-in-other-window) - ;; Go to top of screen (in case user moved point). - (move-to-window-line 0) - (let ((case-fold-search nil)) - (beginning-of-line) - (mh-when (not (and (search-backward "\n\n" nil t) - (search-backward "From:" nil t))) - (other-window -1) - (error "No more messages"))) - ;; Go back to previous blank line, then forward to the first non-blank. - (search-backward "\n\n" nil t) - (forward-line 2) - (mh-recenter 0) - (other-window -1))) - - -(defun mh-page-msg (&optional arg) - "Page the displayed message forwards. -Scrolls ARG lines or a full screen if no argument is supplied." - (interactive "P") - (scroll-other-window arg)) - - -(defun mh-previous-page (&optional arg) - "Page the displayed message backwards. -Scrolls ARG lines or a full screen if no argument is supplied." - (interactive "P") - (save-excursion - (mh-show-message-in-other-window) - (unwind-protect - (scroll-down arg) - (other-window -1)))) - - -(defun mh-previous-undeleted-msg (&optional arg) - "Move to previous undeleted message in window." - (interactive "p") - (setq mh-next-direction 'backward) - (beginning-of-line) - (cond ((re-search-backward mh-good-msg-regexp nil 0 arg) - (mh-maybe-show)) - (t - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) - - -(defun mh-print-msg (prefix-provided msg-or-seq) - "Print MESSAGE(s) (default: displayed message) on a line printer. -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (reverse (mh-seq-to-msgs - (mh-read-seq-default "Print" t))) - (mh-get-msg-num t)))) - (if prefix-provided - (message "Printing sequence...") - (message "Printing message...")) - (let ((print-command - (if prefix-provided - (format "(scan -clear %s ; %s -nobell -clear %s %s) | %s" - (mapconcat (function (lambda (msg) msg)) msg-or-seq " ") - (expand-file-name "mhl" mh-lib) - (if (stringp mhl-formfile) - (format "-form %s" mhl-formfile) - "") - (mh-msg-filenames msg-or-seq) - (format mh-lpr-command-format - (if prefix-provided - (format "Sequence from %s" mh-current-folder) - (format "%s/%d" mh-current-folder - msg-or-seq)))) - (format "%s -nobell -clear %s %s | %s" - (expand-file-name "mhl" mh-lib) - (mh-msg-filename msg-or-seq) - (if (stringp mhl-formfile) - (format "-form %s" mhl-formfile) - "") - (format mh-lpr-command-format - (if prefix-provided - (format "Sequence from %s" mh-current-folder) - (format "%s/%d" mh-current-folder - msg-or-seq))))))) - (if mh-print-background - (mh-exec-cmd-daemon shell-file-name "-c" print-command) - (call-process shell-file-name nil nil nil "-c" print-command)) - (if prefix-provided - (mh-notate-seq msg-or-seq ?P mh-cmd-note) - (mh-notate msg-or-seq ?P mh-cmd-note)) - (mh-add-msgs-to-seq msg-or-seq 'printed t) - (if prefix-provided - (message "Printing sequence...done") - (message "Printing message...done")))) - - -(defun mh-put-msg-in-seq (prefix-provided from to) - "Add MESSAGE(s) (default: displayed message) to SEQUENCE. -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-seq-to-msgs - (mh-read-seq-default "Add messages from" t)) - (mh-get-msg-num t)) - (mh-read-seq-default "Add to" nil))) - (setq mh-previous-seq to) - (mh-add-msgs-to-seq from to)) - - -(defun mh-rescan-folder (&optional range) - "Rescan a folder after optionally processing the outstanding commands. -If optional prefix argument is provided, prompt for the range of -messages to display. Otherwise show the entire folder." - (interactive (list (if current-prefix-arg - (mh-read-msg-range "Range to scan [all]? ") - nil))) - (setq mh-next-direction 'forward) - (mh-scan-folder mh-current-folder (or range "all"))) - - -(defun mh-redistribute (to cc msg) - "Redistribute a letter. -Depending on how your copy of MH was compiled, you may need to change the -setting of the variable mh-redist-full-contents. See its documentation." - (interactive (list (read-string "Redist-To: ") - (read-string "Redist-Cc: ") - (mh-get-msg-num t))) - (save-window-excursion - (let ((folder mh-current-folder) - (draft (mh-read-draft "redistribution" - (if mh-redist-full-contents - (mh-msg-filename msg) - nil) - nil))) - (mh-goto-header-end 0) - (insert "Resent-To: " to "\n") - (if (not (equal cc "")) (insert "Resent-cc: " cc "\n")) - (mh-clean-msg-header (point-min) - "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:" - nil) - (save-buffer) - (message "Redistributing...") - (if mh-redist-full-contents - (call-process "/bin/sh" nil 0 nil "-c" - (format "mhdist=1 mhaltmsg=%s %s -push %s" - (buffer-file-name) - (expand-file-name "send" mh-progs) - (buffer-file-name))) - (call-process "/bin/sh" nil 0 nil "-c" - (format "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s" - (mh-msg-filename msg folder) - (expand-file-name "send" mh-progs) - (buffer-file-name)))) - (mh-annotate-msg msg folder mh-note-dist - "-component" "Resent:" - "-text" (format "\"%s %s\"" to cc)) - (kill-buffer draft) - (message "Redistributing...done")))) - - -(defun mh-write-msg-to-file (msg file) - "Append MESSAGE to the end of a FILE." - (interactive - (list (mh-get-msg-num t) - (let ((default-dir (if (eq 'write (car mh-last-destination)) - (file-name-directory (cdr mh-last-destination)) - default-directory))) - (read-file-name "Save message in file: " default-dir - (expand-file-name "mail.out" default-dir))))) - (let ((file-name (mh-msg-filename msg)) - (output-file (mh-expand-file-name file))) - (setq mh-last-destination (cons 'write file)) - (save-excursion - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer) - (insert-file-contents file-name) - (append-to-file (point-min) (point-max) output-file)))) - - -(defun mh-search-folder (folder) - "Search FOLDER for messages matching a pattern." - (interactive (list (mh-prompt-for-folder "Search" - mh-current-folder - t))) - (switch-to-buffer-other-window "pick-pattern") - (if (or (zerop (buffer-size)) - (not (y-or-n-p "Reuse pattern? "))) - (mh-make-pick-template) - (message "")) - (setq mh-searching-folder folder)) - - -(defun mh-send (to cc subject) - "Compose and send a letter. -The letter is composed in mh-letter-mode; see its documentation for more -details. If `mh-compose-letter-function' is defined, it is called on the -draft and passed three arguments: to, subject, and cc." - (interactive "sTo: \nsCc: \nsSubject: ") - (let ((config (current-window-configuration))) - (delete-other-windows) - (mh-send-sub to cc subject config))) - - -(defun mh-send-other-window (to cc subject) - "Compose and send a letter in another window.." - (interactive "sTo: \nsCc: \nsSubject: ") - (let ((pop-up-windows t)) - (mh-send-sub to cc subject (current-window-configuration)))) - - -(defun mh-send-sub (to cc subject config) - "Do the real work of composing and sending a letter. -Expects the TO, CC, and SUBJECT fields as arguments. -CONFIG is the window configuration before sending mail." - (let ((folder mh-current-folder) - (msg-num (mh-get-msg-num nil))) - (message "Composing a message...") - (let ((draft (mh-read-draft - "message" - (if (file-exists-p - (expand-file-name "components" mh-user-path)) - (expand-file-name "components" mh-user-path) - (if (file-exists-p - (expand-file-name "components" mh-lib)) - (expand-file-name "components" mh-lib) - (error "Can't find components file"))) - nil))) - (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc) - (set-buffer-modified-p nil) - (goto-char (point-max)) - (message "Composing a message...done") - (mh-compose-and-send-mail draft "" folder msg-num - to subject cc - nil nil config)))) - - -(defun mh-show (&optional msg) - "Show MESSAGE (default: displayed message). -Forces a two-window display with the folder window on top (size -mh-summary-height) and the show buffer below it." - (interactive) - (if (not msg) - (setq msg (mh-get-msg-num t))) - (setq mh-showing t) - (mh-set-mode-name "mh-e show") - (if (not (eql (next-window (minibuffer-window)) (selected-window))) - (delete-other-windows)) ; force ourself to the top window - (let ((folder mh-current-folder)) - (mh-show-message-in-other-window) - (mh-display-msg msg folder)) - (other-window -1) - (if (not (= (1+ (window-height)) (screen-height))) ;not horizontally split - (shrink-window (- (window-height) mh-summary-height))) - (mh-recenter nil) - (if (not (memq msg mh-seen-list)) (mh-push msg mh-seen-list))) - - -(defun mh-sort-folder () - "Sort the messages in the current folder by date." - (interactive) - (mh-process-or-undo-commands mh-current-folder) - (setq mh-next-direction 'forward) - (mh-set-folder-modified-p t) ; lock folder while sorting - (message "Sorting folder...") - (mh-exec-cmd "sortm" mh-current-folder) - (message "Sorting folder...done") - (mh-scan-folder mh-current-folder "all")) - - -(defun mh-toggle-showing () - "Toggle the scanning mode/showing mode of displaying messages." - (interactive) - (if mh-showing - (mh-set-scan-mode) - (mh-show))) - - -(defun mh-undo (prefix-provided msg-or-seq) - "Undo the deletion or refile of the specified MESSAGE(s). -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Undo" t) - (mh-get-msg-num t)))) - (cond (prefix-provided - (mh-mapc (function mh-undo-msg) (mh-seq-to-msgs msg-or-seq))) - (t - (let ((original-position (point))) - (beginning-of-line) - (while (not (or (looking-at mh-deleted-msg-regexp) - (looking-at mh-refiled-msg-regexp) - (and (eq mh-next-direction 'forward) (bobp)) - (and (eq mh-next-direction 'backward) - (save-excursion (forward-line) (eobp))))) - (forward-line (if (eq mh-next-direction 'forward) -1 1))) - (if (or (looking-at mh-deleted-msg-regexp) - (looking-at mh-refiled-msg-regexp)) - (progn - (mh-undo-msg (mh-get-msg-num t)) - (mh-maybe-show)) - (goto-char original-position) - (error "Nothing to undo"))))) - ;; update the mh-refile-list so mh-outstanding-commands-p will work - (mh-mapc (function - (lambda (elt) - (if (not (mh-seq-to-msgs elt)) - (setq mh-refile-list (delq elt mh-refile-list))))) - mh-refile-list) - (if (not (mh-outstanding-commands-p)) - (mh-set-folder-modified-p nil))) - - -(defun mh-undo-msg (msg) - ;; Undo the deletion or refile of one MESSAGE. - (cond ((memq msg mh-delete-list) - (setq mh-delete-list (delq msg mh-delete-list)) - (mh-remove-msg-from-seq msg 'deleted t)) - (t - (mh-mapc (function (lambda (dest) - (mh-remove-msg-from-seq msg dest t))) - mh-refile-list))) - (mh-notate msg ? mh-cmd-note)) - - -(defun mh-undo-folder (&rest ignore) - "Undo all commands in current folder." - (interactive) - (cond ((or mh-do-not-confirm - (yes-or-no-p "Undo all commands in folder? ")) - (setq mh-delete-list nil - mh-refile-list nil - mh-seq-list nil - mh-next-direction 'forward) - (with-mh-folder-updating (nil) - (mh-unmark-all-headers t))) - (t - (message "Commands not undone.") - (sit-for 2)))) - - -(defun mh-unshar-msg (dir) - "Unpack the shar file contained in the current message into directory DIR." - (interactive (list (read-file-name "Unshar message in directory: " - mh-unshar-default-directory - mh-unshar-default-directory nil))) - (mh-display-msg (mh-get-msg-num t) mh-current-folder) ;update show buffer - (mh-unshar-buffer dir)) - -(defun mh-unshar-buffer (dir) - ;; Unpack the shar file contained in the current buffer into directory DIR. - (goto-char (point-min)) - (if (or (re-search-forward "^#![ \t]*/bin/sh" nil t) - (and (re-search-forward "^[^a-z0-9\"]*cut here\b" nil t) - (forward-line 1)) - (re-search-forward "^#" nil t) - (re-search-forward "^: " nil t)) - (let ((default-directory (expand-file-name dir)) - (start (progn (beginning-of-line) (point))) - (log-buffer (get-buffer-create "*Unshar Output*"))) - (save-excursion - (set-buffer log-buffer) - (setq default-directory (expand-file-name dir)) - (erase-buffer) - (if (file-directory-p default-directory) - (insert "cd " dir "\n") - (insert "mkdir " dir "\n") - (call-process "mkdir" nil log-buffer t default-directory))) - (set-window-start (display-buffer log-buffer) 0) ;so can watch progress - (call-process-region start (point-max) "sh" nil log-buffer t)) - (error "Cannot find start of shar."))) - - -(defun mh-visit-folder (folder &optional range) - "Visit FOLDER and display RANGE of messages. -Assumes mh-e has already been initialized." - (interactive (list (mh-prompt-for-folder "Visit" "+inbox" t) - (mh-read-msg-range "Range [all]? "))) - (let ((config (current-window-configuration))) - (mh-scan-folder folder (or range "all")) - (setq mh-previous-window-config config)) - nil) - - -(defun mh-widen () - "Remove restrictions from the current folder, thereby showing all messages." - (interactive) - (if mh-narrowed-to-seq - (with-mh-folder-updating (t) - (delete-region (point-min) (point-max)) - (widen) - (mh-make-folder-mode-line))) - (setq mh-narrowed-to-seq nil)) - - - -;;; Support routines. - -(defun mh-delete-a-msg (msg) - ;; Delete the MESSAGE. - (save-excursion - (mh-goto-msg msg nil t) - (if (looking-at mh-refiled-msg-regexp) - (error "Message %d is refiled. Undo refile before deleting." msg)) - (if (looking-at mh-deleted-msg-regexp) - nil - (mh-set-folder-modified-p t) - (mh-push msg mh-delete-list) - (mh-add-msgs-to-seq msg 'deleted t) - (mh-notate msg ?D mh-cmd-note)))) - - -(defun mh-refile-a-msg (msg destination) - ;; Refile MESSAGE in FOLDER. FOLDER is a symbol, not a string. - (save-excursion - (mh-goto-msg msg nil t) - (cond ((looking-at mh-deleted-msg-regexp) - (error "Message %d is deleted. Undo delete before moving." msg)) - ((looking-at mh-refiled-msg-regexp) - (if (y-or-n-p - (format "Message %d already refiled. Copy to %s as well? " - msg destination)) - (mh-exec-cmd "refile" (mh-get-msg-num t) "-link" - "-src" mh-current-folder - (symbol-name destination)) - (message "Message not copied."))) - (t - (mh-set-folder-modified-p t) - (if (not (memq destination mh-refile-list)) - (mh-push destination mh-refile-list)) - (if (not (memq msg (mh-seq-to-msgs destination))) - (mh-add-msgs-to-seq msg destination t)) - (mh-notate msg ?^ mh-cmd-note))))) - - -(defun mh-display-msg (msg-num folder) - ;; Display message NUMBER of FOLDER. - ;; Sets the current buffer to the show buffer. - (set-buffer folder) - ;; Bind variables in folder buffer in case they are local - (let ((formfile mhl-formfile) - (clean-message-header mh-clean-message-header) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers) - (msg-filename (mh-msg-filename msg-num)) - (show-buffer mh-show-buffer) - (folder mh-current-folder)) - (if (not (file-exists-p msg-filename)) - (error "Message %d does not exist" msg-num)) - (switch-to-buffer show-buffer) - (if mh-bury-show-buffer (bury-buffer (current-buffer))) - (mh-when (not (equal msg-filename buffer-file-name)) - ;; Buffer does not yet contain message. - (clear-visited-file-modtime) - (unlock-buffer) - (setq buffer-file-name nil) ; no locking during setup - (erase-buffer) - (if formfile - (if (stringp formfile) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - "-form" formfile msg-filename) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - msg-filename)) - (insert-file-contents msg-filename)) - (goto-char (point-min)) - (cond (clean-message-header - (mh-clean-msg-header (point-min) - invisible-headers - visible-headers) - (goto-char (point-min))) - (t - (let ((case-fold-search t)) - (re-search-forward - "^To:\\|^From:\\|^Subject:\\|^Date:" nil t) - (beginning-of-line) - (mh-recenter 0)))) - (set-buffer-modified-p nil) - (setq buffer-file-name msg-filename) - (set-mark nil) - (setq mode-line-buffer-identification - (list (format mh-show-buffer-mode-line-buffer-id - folder msg-num)))))) - - -(defun mh-invalidate-show-buffer () - ;; Invalidate the show buffer so we must update it to use it. - (if (get-buffer mh-show-buffer) - (save-excursion - (set-buffer mh-show-buffer) - (setq buffer-file-name nil)))) - - -(defun mh-show-message-in-other-window () - (switch-to-buffer-other-window mh-show-buffer) - (if mh-bury-show-buffer (bury-buffer (current-buffer)))) - - -(defun mh-clean-msg-header (start invisible-headers visible-headers) - ;; Flush extraneous lines in a message header, from the given POINT to the - ;; end of the message header. If VISIBLE-HEADERS is non-nil, it contains a - ;; regular expression specifying the lines to display, otherwise - ;; INVISIBLE-HEADERS contains a regular expression specifying lines to - ;; delete from the header. - (let ((case-fold-search t)) - (save-restriction - (goto-char start) - (if (search-forward "\n\n" nil t) - (backward-char 1)) - (narrow-to-region start (point)) - (goto-char (point-min)) - (if visible-headers - (while (< (point) (point-max)) - (beginning-of-line) - (cond ((looking-at visible-headers) - (forward-line 1) - (while (looking-at "^[ \t]+") (forward-line 1))) - (t - (mh-delete-line 1) - (while (looking-at "^[ \t]+") - (beginning-of-line) - (mh-delete-line 1))))) - (while (re-search-forward invisible-headers nil t) - (beginning-of-line) - (mh-delete-line 1) - (while (looking-at "^[ \t]+") - (beginning-of-line) - (mh-delete-line 1)))) - (unlock-buffer)))) - - -(defun mh-delete-line (lines) - ;; Delete version of kill-line. - (delete-region (point) (save-excursion (forward-line lines) (point)))) - - -(defun mh-read-draft (use initial-contents delete-contents-file) - ;; Read draft file into a draft buffer and make that buffer the current one. - ;; USE is a message used for prompting about the intended use of the message. - ;; INITIAL-CONTENTS is filename that is read into an empty buffer, or NIL - ;; if buffer should not be modified. Delete the initial-contents file if - ;; DELETE-CONTENTS-FILE flag is set. - ;; Returns the draft folder's name. - ;; If the draft folder facility is enabled in ~/.mh_profile, a new buffer is - ;; used each time and saved in the draft folder. The draft file can then be - ;; reused. - (cond (mh-draft-folder - (let ((orig-default-dir default-directory)) - (pop-to-buffer (find-file-noselect (mh-new-draft-name)) t) - (rename-buffer (format "draft-%s" (buffer-name))) - (setq default-directory orig-default-dir))) - (t - (let ((draft-name (expand-file-name "draft" mh-user-path))) - (pop-to-buffer "draft") ; Create if necessary - (if (buffer-modified-p) - (if (y-or-n-p "Draft has been modified; kill anyway? ") - (set-buffer-modified-p nil) - (error "Draft preserved"))) - (setq buffer-file-name draft-name) - (clear-visited-file-modtime) - (unlock-buffer) - (mh-when (and (file-exists-p draft-name) - (not (equal draft-name initial-contents))) - (insert-file-contents draft-name) - (delete-file draft-name))))) - (mh-when (and initial-contents - (or (zerop (buffer-size)) - (not (y-or-n-p - (format "A draft exists. Use for %s? " use))))) - (erase-buffer) - (insert-file-contents initial-contents) - (if delete-contents-file (delete-file initial-contents))) - (auto-save-mode 1) - (if mh-draft-folder - (save-buffer)) ; Do not reuse draft name - (buffer-name)) - - -(defun mh-new-draft-name () - ;; Returns the pathname of folder for draft messages. - (save-excursion - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer) - (mh-exec-cmd-output "mhpath" nil mh-draft-folder "new") - (buffer-substring (point) (1- (mark t))))) - - -(defun mh-next-msg () - ;; Move backward or forward to the next undeleted message in the buffer. - (if (eq mh-next-direction 'forward) - (mh-next-undeleted-msg 1) - (mh-previous-undeleted-msg 1))) - - -(defun mh-set-scan-mode () - ;; Display the scan listing buffer, but do not show a message. - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer)) - (mh-set-mode-name "mh-e scan") - (setq mh-showing nil) - (if mh-recenter-summary-p - (mh-recenter nil))) - - -(defun mh-maybe-show (&optional msg) - ;; If in showing mode, then display the message pointed to by the cursor. - (if mh-showing (mh-show msg))) - - -(defun mh-set-mode-name (mode-name-string) - ;; Set the mode-name and ensure that the mode line is updated. - (setq mode-name mode-name-string) - ;; Force redisplay of all buffers' mode lines to be considered. - (save-excursion (set-buffer (other-buffer))) - (set-buffer-modified-p (buffer-modified-p))) - - - -;;; The folder data abstraction. - -(defvar mh-current-folder nil "Name of current folder, a string.") -(defvar mh-show-buffer nil "Buffer that displays message for this folder.") -(defvar mh-folder-filename nil "Full path of directory for this folder.") -(defvar mh-showing nil "If non-nil, show the message in a separate window.") -(defvar mh-next-seq-num nil "Index of free sequence id.") -(defvar mh-delete-list nil "List of msg numbers to delete.") -(defvar mh-refile-list nil "List of folder names in mh-seq-list.") -(defvar mh-seq-list nil "Alist of (seq . msgs) numbers.") -(defvar mh-seen-list nil "List of displayed messages.") -(defvar mh-next-direction 'forward "Direction to move to next message.") -(defvar mh-narrowed-to-seq nil "Sequence display is narrowed to.") -(defvar mh-first-msg-num nil "Number of first msg in buffer.") -(defvar mh-last-msg-num nil "Number of last msg in buffer.") - - -(defun mh-make-folder (name) - ;; Create and initialize a new mail folder called NAME and make it the - ;; current folder. - (switch-to-buffer name) - (setq buffer-read-only nil) - (erase-buffer) - (setq buffer-read-only t) - (mh-folder-mode) - (mh-set-folder-modified-p nil) - (setq buffer-file-name mh-folder-filename) - (mh-set-mode-name "mh-e scan")) - - -;;; Don't use this mode when creating buffers if default-major-mode is nil. -(put 'mh-folder-mode 'mode-class 'special) - -(defun mh-folder-mode () - "Major mode for \"editing\" an MH folder scan listing. -Messages can be marked for refiling and deletion. However, both actions -are deferred until you request execution with \\[mh-execute-commands]. -\\{mh-folder-mode-map} - A prefix argument (\\[universal-argument]) to delete, refile, list, or undo -applies the action to a message sequence. - -Variables controlling mh-e operation are (defaults in parentheses): - - mh-bury-show-buffer (t) - Non-nil means that the buffer used to display message is buried. - It will never be offered as the default other buffer. - - mh-clean-message-header (nil) - Non-nil means remove header lines matching the regular expression - specified in mh-invisible-headers from messages. - - mh-visible-headers (nil) - If non-nil, it contains a regexp specifying the headers that are shown in - a message if mh-clean-message-header is non-nil. Setting this variable - overrides mh-invisible-headers. - - mh-do-not-confirm (nil) - Non-nil means do not prompt for confirmation before executing some - non-recoverable commands such as mh-kill-folder and mh-undo-folder. - - mhl-formfile (nil) - Name of format file to be used by mhl to show messages. - A value of T means use the default format file. - Nil means don't use mhl to format messages. - - mh-lpr-command-format (\"lpr -p -J '%s'\") - Format for command used to print a message on a system printer. - - mh-recenter-summary-p (nil) - If non-nil, then the scan listing is recentered when the window displaying - a messages is toggled off. - - mh-summary-height (4) - Number of lines in the summary window including the mode line. - - mh-ins-buf-prefix (\"> \") - String to insert before each non-blank line of a message as it is - inserted in a draft letter. - -The value of mh-folder-mode-hook is called when a new folder is set up." - - (kill-all-local-variables) - (use-local-map mh-folder-mode-map) - (setq major-mode 'mh-folder-mode) - (mh-set-mode-name "mh-e folder") - (make-local-vars - 'mh-current-folder (buffer-name) ; Name of folder, a string - 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs - 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" - (file-name-as-directory (mh-expand-file-name (buffer-name))) - 'mh-showing nil ; Show message also? - 'mh-next-seq-num 0 ; Index of free sequence id - 'mh-delete-list nil ; List of msgs nums to delete - 'mh-refile-list nil ; List of folder names in mh-seq-list - 'mh-seq-list nil ; Alist of (seq . msgs) nums - 'mh-seen-list nil ; List of displayed messages - 'mh-next-direction 'forward ; Direction to move to next message - 'mh-narrowed-to-seq nil ; Sequence display is narrowed to - 'mh-first-msg-num nil ; Number of first msg in buffer - 'mh-last-msg-num nil ; Number of last msg in buffer - 'mh-previous-window-config nil) ; Previous window configuration - (setq truncate-lines t) - (auto-save-mode -1) - (setq buffer-offer-save t) - (make-local-variable 'write-file-hooks) - (setq write-file-hooks '(mh-execute-commands)) - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'mh-undo-folder) - (run-hooks 'mh-folder-mode-hook)) - - -(defun make-local-vars (&rest pairs) - ;; Take VARIABLE-VALUE pairs and makes local variables initialized to the - ;; value. - (while pairs - (make-variable-buffer-local (car pairs)) - (set (car pairs) (car (cdr pairs))) - (setq pairs (cdr (cdr pairs))))) - - -(defun mh-scan-folder (folder range) - ;; Scan the FOLDER over the RANGE. Return in the folder's buffer. - (cond ((null (get-buffer folder)) - (mh-make-folder folder)) - (t - (mh-process-or-undo-commands folder) - (switch-to-buffer folder))) - (mh-regenerate-headers range) - (mh-when (zerop (buffer-size)) - (if (equal range "all") - (message "Folder %s is empty" folder) - (message "No messages in %s, range %s" folder range)) - (sit-for 5)) - (mh-goto-cur-msg)) - - -(defun mh-regenerate-headers (range) - ;; Replace buffer with scan of its contents over range RANGE. - (let ((folder mh-current-folder)) - (message "Scanning %s..." folder) - (with-mh-folder-updating (nil) - (erase-buffer) - (mh-exec-cmd-output "scan" nil - "-noclear" "-noheader" - "-width" (window-width) - folder range) - (goto-char (point-min)) - (cond ((looking-at "scan: no messages in") - (keep-lines mh-valid-scan-line)) ; Flush random scan lines - ((looking-at "scan: ")) ; Keep error messages - (t - (keep-lines mh-valid-scan-line))) ; Flush random scan lines - (mh-delete-seq-locally 'cur) ; To pick up new one - (setq mh-seq-list (mh-read-folder-sequences folder nil)) - (mh-notate-user-sequences) - (mh-make-folder-mode-line (if (equal range "all") - nil - mh-partial-folder-mode-line-annotation))) - (message "Scanning %s...done" folder))) - - -(defun mh-get-new-mail (maildrop-name) - ;; Read new mail from a maildrop into the current buffer. - ;; Return T if there was new mail, NIL otherwise. Return in the current - ;; buffer. - (let ((point-before-inc (point)) - (folder mh-current-folder) - (return-value t)) - (with-mh-folder-updating (t) - (message (if maildrop-name - (format "inc %s -file %s..." folder maildrop-name) - (format "inc %s..." folder))) - (mh-unmark-all-headers nil) - (setq mh-next-direction 'forward) - (goto-char (point-max)) - (let ((start-of-inc (point))) - (if maildrop-name - (mh-exec-cmd-output "inc" nil folder - "-file" (expand-file-name maildrop-name) - "-width" (window-width) - "-truncate") - (mh-exec-cmd-output "inc" nil - "-width" (window-width))) - (message - (if maildrop-name - (format "inc %s -file %s...done" folder maildrop-name) - (format "inc %s...done" folder))) - (goto-char start-of-inc) - (cond ((looking-at "inc: no mail") - (keep-lines mh-valid-scan-line) ; Flush random scan lines - (goto-char point-before-inc) - (message "No new mail%s%s" (if maildrop-name " in " "") - (if maildrop-name maildrop-name ""))) - ((re-search-forward "^inc:" nil t) ; Error messages - (error "inc error")) - (t - (mh-delete-seq-locally 'cur) ; To pick up new one - (setq mh-seq-list (mh-read-folder-sequences folder t)) - (mh-notate-user-sequences) - (keep-lines mh-valid-scan-line) - (mh-make-folder-mode-line) - (mh-goto-cur-msg) - (setq return-value t)))) - return-value))) - - -(defun mh-make-folder-mode-line (&optional annotation) - ;; Set the fields of the mode line for a folder buffer. - ;; The optional ANNOTATION string is displayed after the folder's name. - (save-excursion - (mh-first-msg) - (setq mh-first-msg-num (mh-get-msg-num nil)) - (mh-last-msg) - (setq mh-last-msg-num (mh-get-msg-num nil)) - (let ((lines (count-lines (point-min) (point-max)))) - (setq mode-line-buffer-identification - (list (format "{%%b%s} %d msg%s" - (if annotation (format "/%s" annotation) "") - lines - (if (zerop lines) - "s" - (if (> lines 1) - (format "s (%d-%d)" mh-first-msg-num - mh-last-msg-num) - (format " (%d)" mh-first-msg-num))))))))) - - -(defun mh-unmark-all-headers (remove-all-flags) - ;; Remove all '+' flags from the headers, and if called with a non-nil - ;; argument, remove all 'D', '^' and '%' flags too. - ;; Optimized for speed (i.e., no regular expressions). - (save-excursion - (let ((case-fold-search nil) - (last-line (- (point-max) mh-cmd-note)) - char) - (mh-first-msg) - (while (<= (point) last-line) - (forward-char mh-cmd-note) - (setq char (following-char)) - (if (or (and remove-all-flags - (or (eql char ?D) - (eql char ?^) - (eql char ?%))) - (eql char ?+)) - (progn - (delete-char 1) - (insert " "))) - (forward-line))))) - - -(defun mh-goto-cur-msg () - ;; Position the cursor at the current message. - (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) - (cond ((and cur-msg - (mh-goto-msg cur-msg t nil)) - (mh-notate nil ?+ mh-cmd-note) - (mh-recenter 0) - (mh-maybe-show cur-msg)) - (t - (mh-last-msg) - (message "No current message"))))) - - -(defun mh-pack-folder-1 (range) - ;; Close and pack the current folder. - (mh-process-or-undo-commands mh-current-folder) - (message "Packing folder...") - (mh-set-folder-modified-p t) ; lock folder while packing - (save-excursion - (mh-exec-cmd-quiet " *mh-temp*" "folder" mh-current-folder "-pack")) - (mh-regenerate-headers range)) - - -(defun mh-process-or-undo-commands (folder) - ;; If FOLDER has outstanding commands, then either process or discard them. - (set-buffer folder) - (if (mh-outstanding-commands-p) - (if (or mh-do-not-confirm - (y-or-n-p - "Process outstanding deletes and refiles (or lose them)? ")) - (mh-process-commands folder) - (mh-undo-folder)) - (mh-invalidate-show-buffer))) - - -(defun mh-process-commands (folder) - ;; Process outstanding commands for the folder FOLDER. - (message "Processing deletes and refiles for %s..." folder) - (set-buffer folder) - (with-mh-folder-updating (nil) - ;; Update the unseen sequence if it exists - (if (and mh-seen-list (mh-seq-to-msgs mh-unseen-seq)) - (mh-undefine-sequence mh-unseen-seq mh-seen-list)) - - ;; Then refile messages - (mh-mapc - (function - (lambda (dest) - (let ((msgs (mh-seq-to-msgs dest))) - (mh-when msgs - (apply 'mh-exec-cmd "refile" - "-src" folder (symbol-name dest) msgs) - (mh-delete-scan-msgs msgs))))) - mh-refile-list) - - ;; Now delete messages - (mh-when mh-delete-list - (apply 'mh-exec-cmd "rmm" folder mh-delete-list) - (mh-delete-scan-msgs mh-delete-list)) - - ;; Don't need to remove sequences since delete and refile do so. - - ;; Mark cur message - (if (> (buffer-size) 0) - (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last")))) - - (mh-invalidate-show-buffer) - - (setq mh-delete-list nil - mh-refile-list nil - mh-seq-list (mh-read-folder-sequences mh-current-folder nil) - mh-seen-list nil) - (mh-unmark-all-headers t) - (mh-notate-user-sequences) - (message "Processing deletes and refiles for %s...done" folder))) - - -(defun mh-delete-scan-msgs (msgs) - ;; Delete the scan listing lines for each of the msgs in the LIST. - ;; Optimized for speed (i.e., no regular expressions). - (setq msgs (sort msgs (function <))) ;okay to clobber msgs - (save-excursion - (mh-first-msg) - (while (and msgs (< (point) (point-max))) - (cond ((equal (mh-get-msg-num nil) (car msgs)) - (delete-region (point) (save-excursion (forward-line) (point))) - (setq msgs (cdr msgs))) - (t - (forward-line)))))) - - -(defun mh-set-folder-modified-p (flag) - "Mark current folder as modified or unmodified according to FLAG." - (set-buffer-modified-p flag)) - - -(defun mh-outstanding-commands-p () - ;; Returns non-nil if there are outstanding deletes or refiles. - (or mh-delete-list mh-refile-list)) - - - -;;; Mode for composing and sending a draft message. - -(defvar mh-sent-from-folder nil - "Folder of msg associated with this letter.") - -(defvar mh-sent-from-msg nil - "Number of msg associated with this letter.") - -(defvar mh-send-args nil - "Extra arguments to pass to \"send\" command.") - -(defvar mh-annotate-char nil - "Character to use to annotate mh-sent-from-msg.") - -(defvar mh-annotate-field nil - "Field name for message annotation.") - -(defun mh-letter-mode () - "Mode for composing letters in mh-e. -When you have finished composing, type \\[mh-send-letter] to send the letter. - -Variables controlling this mode (defaults in parentheses): - - mh-delete-yanked-msg-window (nil) - If non-nil, \\[mh-yank-cur-msg] will delete any windows displaying - the yanked message. - - mh-yank-from-start-of-msg (t) - If non-nil, \\[mh-yank-cur-msg] will include the entire message. - If `body', just yank the body (no header). - If nil, only the portion of the message following the point will be yanked. - If there is a region, this variable is ignored. - - mh-signature-file-name (\"~/.signature\") - File to be inserted into message by \\[mh-insert-signature]. - -Upon invoking mh-letter-mode, text-mode-hook and mh-letter-mode-hook are -invoked with no args, if those values are non-nil. - -\\{mh-letter-mode-map}" - (interactive) - (kill-all-local-variables) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-start)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate - (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-separate)) - (make-local-variable 'mh-send-args) - (make-local-variable 'mh-annotate-char) - (make-local-variable 'mh-annotate-field) - (make-local-variable 'mh-previous-window-config) - (make-local-variable 'mh-sent-from-folder) - (make-local-variable 'mh-sent-from-msg) - (use-local-map mh-letter-mode-map) - (setq major-mode 'mh-letter-mode) - (mh-set-mode-name "mh-e letter") - (set-syntax-table mh-letter-mode-syntax-table) - (run-hooks 'text-mode-hook 'mh-letter-mode-hook) - (mh-when (and (boundp 'auto-fill-hook) auto-fill-hook) ;emacs 18 - (make-local-variable 'auto-fill-hook) - (setq auto-fill-hook 'mh-auto-fill-for-letter)) - (mh-when (and (boundp 'auto-fill-function) auto-fill-function) ;emacs 19 - (make-local-variable 'auto-fill-function) - (setq auto-fill-function 'mh-auto-fill-for-letter))) - - -(defun mh-auto-fill-for-letter () - ;; Auto-fill in letters treats the header specially by inserting a tab - ;; before continuation line. - (do-auto-fill) - (if (mh-in-header-p) - (save-excursion - (beginning-of-line nil) - (insert-char ?\t 1)))) - - -(defun mh-in-header-p () - ;; Return non-nil if the point is in the header of a draft message. - (save-excursion - (let ((cur-point (point))) - (goto-char (point-min)) - (re-search-forward "^--------" nil t) - (< cur-point (point))))) - - -(defun mh-to-field () - "Move point to the end of a specified header field. -The field is indicated by the previous keystroke. Create the field if -it does not exist. Set the mark to point before moving." - (interactive) - (expand-abbrev) - (let ((target (cdr (assoc (logior last-input-char ?`) mh-to-field-choices))) - (case-fold-search t)) - (cond ((mh-position-on-field target t) - (let ((eol (point))) - (skip-chars-backward " \t") - (delete-region (point) eol)) - (if (and (not (eq (logior last-input-char ?`) ?s)) - (save-excursion - (backward-char 1) - (not (looking-at "[:,]")))) - (insert ", ") - (insert " "))) - (t - (goto-char (point-min)) - (re-search-forward "^To:") - (forward-line 1) - (while (looking-at "^[ \t]") (forward-line 1)) - (insert (format "%s \n" target)) - (backward-char 1))))) - - -(defun mh-to-fcc () - "Insert an Fcc: field in the current message. -Prompt for the field name with a completion list of the current folders." - (interactive) - (let ((last-input-char ?\C-f) - (folder (mh-prompt-for-folder "Fcc" "" t))) - (expand-abbrev) - (save-excursion - (mh-to-field) - (insert (substring folder 1 nil))))) - - -(defun mh-insert-signature () - "Insert the file named by mh-signature-file-name at the current point." - (interactive) - (insert-file-contents mh-signature-file-name) - (set-buffer-modified-p (buffer-modified-p))) ; force mode line update - - -(defun mh-check-whom () - "Verify recipients of the current letter." - (interactive) - (let ((file-name (buffer-file-name))) - (set-buffer-modified-p t) ; Force writing of contents - (save-buffer) - (message "Checking recipients...") - (switch-to-buffer-other-window "*Mail Recipients*") - (bury-buffer (current-buffer)) - (erase-buffer) - (mh-exec-cmd-output "whom" t file-name) - (other-window -1) - (message "Checking recipients...done"))) - - - -;;; Routines to make a search pattern and search for a message. - -(defvar mh-searching-folder nil "Folder this pick is searching.") - - -(defun mh-make-pick-template () - ;; Initialize the current buffer with a template for a pick pattern. - (erase-buffer) - (kill-all-local-variables) - (make-local-variable 'mh-searching-folder) - (insert "From: \n" - "To: \n" - "Cc: \n" - "Date: \n" - "Subject: \n" - "---------\n") - (mh-letter-mode) - (use-local-map mh-pick-mode-map) - (goto-char (point-min)) - (end-of-line)) - - -(defun mh-do-pick-search () - "Find messages that match the qualifications in the current pattern buffer. -Messages are searched for in the folder named in mh-searching-folder. -Put messages found in a sequence named `search'." - (interactive) - (let ((pattern-buffer (buffer-name)) - (searching-buffer mh-searching-folder) - range msgs - (pattern nil) - (new-buffer nil)) - (save-excursion - (cond ((get-buffer searching-buffer) - (set-buffer searching-buffer) - (setq range (format "%d-%d" mh-first-msg-num mh-last-msg-num))) - (t - (mh-make-folder searching-buffer) - (setq range "all") - (setq new-buffer t)))) - (message "Searching...") - (goto-char (point-min)) - (while (setq pattern (mh-next-pick-field pattern-buffer)) - (setq msgs (mh-seq-from-command searching-buffer - 'search - (nconc (cons "pick" pattern) - (list searching-buffer - range - "-sequence" "search" - "-list")))) - (setq range "search")) - (message "Searching...done") - (if new-buffer - (mh-scan-folder searching-buffer msgs) - (switch-to-buffer searching-buffer)) - (delete-other-windows) - (mh-notate-seq 'search ?% (1+ mh-cmd-note)))) - - -(defun mh-next-pick-field (buffer) - ;; Return the next piece of a pick argument that can be extracted from the - ;; BUFFER. Returns nil if no pieces remain. - (set-buffer buffer) - (let ((case-fold-search t)) - (cond ((eobp) - nil) - ((re-search-forward "^\\([a-z].*\\):[ \t]*\\([a-z0-9].*\\)$" nil t) - (let* ((component - (format "--%s" - (downcase (buffer-substring (match-beginning 1) - (match-end 1))))) - (pat (buffer-substring (match-beginning 2) (match-end 2)))) - (forward-line 1) - (list component pat))) - ((re-search-forward "^-*$" nil t) - (forward-char 1) - (let ((body (buffer-substring (point) (point-max)))) - (if (and (> (length body) 0) (not (equal body "\n"))) - (list "-search" body) - nil))) - (t - nil)))) - - - -;;; Routines to compose and send a letter. - -(defun mh-compose-and-send-mail (draft send-args - sent-from-folder sent-from-msg - to subject cc - annotate-char annotate-field - config) - ;; Edit and compose a draft message in buffer DRAFT and send or save it. - ;; SENT-FROM-FOLDER is buffer containing scan listing of current folder, or - ;; nil if none exists. - ;; SENT-FROM-MSG is the message number or sequence name or nil. - ;; SEND-ARGS is an optional argument passed to the send command. - ;; The TO, SUBJECT, and CC fields are passed to the - ;; mh-compose-letter-function. - ;; If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the - ;; message. In that case, the ANNOTATE-FIELD is used to build a string - ;; for mh-annotate-msg. - ;; CONFIG is the window configuration to restore after sending the letter. - (pop-to-buffer draft) - (mh-letter-mode) - (setq mh-sent-from-folder sent-from-folder) - (setq mh-sent-from-msg sent-from-msg) - (setq mh-send-args send-args) - (setq mh-annotate-char annotate-char) - (setq mh-annotate-field annotate-field) - (setq mh-previous-window-config config) - (setq mode-line-buffer-identification (list "{%b}")) - (if (and (boundp 'mh-compose-letter-function) - (symbol-value 'mh-compose-letter-function)) - ;; run-hooks will not pass arguments. - (let ((value (symbol-value 'mh-compose-letter-function))) - (if (and (listp value) (not (eq (car value) 'lambda))) - (while value - (funcall (car value) to subject cc) - (setq value (cdr value))) - (funcall mh-compose-letter-function to subject cc))))) - - -(defun mh-send-letter (&optional arg) - "Send the draft letter in the current buffer. -If optional prefix argument is provided, monitor delivery. -Run mh-before-send-letter-hook before doing anything." - (interactive "P") - (run-hooks 'mh-before-send-letter-hook) - (set-buffer-modified-p t) ; Make sure buffer is written - (save-buffer) - (message "Sending...") - (let ((draft-buffer (current-buffer)) - (file-name (buffer-file-name)) - (config mh-previous-window-config)) - (cond (arg - (pop-to-buffer "MH mail delivery") - (erase-buffer) - (if mh-send-args - (mh-exec-cmd-output "send" t "-watch" "-nopush" - "-nodraftfolder" mh-send-args file-name) - (mh-exec-cmd-output "send" t "-watch" "-nopush" - "-nodraftfolder" file-name)) - (goto-char (point-max)) ; show the interesting part - (recenter -1) - (set-buffer draft-buffer)) ; for annotation below - (mh-send-args - (mh-exec-cmd-daemon "send" "-nodraftfolder" "-noverbose" - mh-send-args file-name)) - (t - (mh-exec-cmd-daemon "send" "-nodraftfolder" "-noverbose" - file-name))) - - (if mh-annotate-char - (mh-annotate-msg mh-sent-from-msg - mh-sent-from-folder - mh-annotate-char - "-component" mh-annotate-field - "-text" (format "\"%s %s\"" - (mh-get-field "To:") - (mh-get-field "Cc:")))) - - (mh-when (or (not arg) - (y-or-n-p "Kill draft buffer? ")) - (kill-buffer draft-buffer) - (if config - (set-window-configuration config))) - (message "Sending...done"))) - - -(defun mh-insert-letter (prefix-provided folder msg) - "Insert a message from any folder into the current letter. -Removes the message's headers using mh-invisible-headers. -Prefixes each non-blank line with mh-ins-buf-prefix (default \">> \"). -If optional prefix argument provided, do not indent and do not delete -headers. Leaves the mark before the letter and point after it." - (interactive - (list current-prefix-arg - (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) - (read-input (format "Message number%s: " - (if mh-sent-from-msg - (format " [%d]" mh-sent-from-msg) - ""))))) - (save-restriction - (narrow-to-region (point) (point)) - (let ((start (point-min))) - (if (equal msg "") (setq msg (int-to-string mh-sent-from-msg))) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - (expand-file-name msg - (mh-expand-file-name folder))) - (mh-when (not prefix-provided) - (mh-clean-msg-header start mh-invisible-headers mh-visible-headers) - (set-mark start) ; since mh-clean-msg-header moves it - (mh-insert-prefix-string mh-ins-buf-prefix))))) - - -(defun mh-yank-cur-msg () - "Insert the current message into the draft buffer. -Prefix each non-blank line in the message with the string in -`mh-ins-buf-prefix'. If a region is set in the message's buffer, then -only the region will be inserted. Otherwise, the entire message will -be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable -is nil, the portion of the message following the point will be yanked. -If `mh-delete-yanked-msg-window' is non-nil, any window displaying the -yanked message will be deleted." - (interactive) - (if (and mh-sent-from-folder mh-sent-from-msg) - (let ((to-point (point)) - (to-buffer (current-buffer))) - (set-buffer mh-sent-from-folder) - (if mh-delete-yanked-msg-window - (delete-windows-on mh-show-buffer)) - (set-buffer mh-show-buffer) ; Find displayed message - (let ((mh-ins-str (cond (mark-active - (buffer-substring (region-beginning) - (region-end))) - ((eq 'body mh-yank-from-start-of-msg) - (buffer-substring - (save-excursion - (goto-char (point-min)) - (mh-goto-header-end 1) - (point)) - (point-max))) - (mh-yank-from-start-of-msg - (buffer-substring (point-min) (point-max))) - (t - (buffer-substring (point) (point-max)))))) - (set-buffer to-buffer) - (narrow-to-region to-point to-point) - (push-mark) - (insert mh-ins-str) - (mh-insert-prefix-string mh-ins-buf-prefix) - (insert "\n") - (widen))) - (error "There is no current message"))) - - -(defun mh-insert-prefix-string (mh-ins-string) - ;; Run MH-YANK-HOOK to insert a prefix string before each line in the buffer. - ;; Generality for supercite users. - (save-excursion - (set-mark (point-max)) - (goto-char (point-min)) - (run-hooks 'mh-yank-hooks))) - - -(defun mh-fully-kill-draft () - "Kill the draft message file and the draft message buffer. -Use \\[kill-buffer] if you don't want to delete the draft message file." - (interactive) - (if (y-or-n-p "Kill draft message? ") - (let ((config mh-previous-window-config)) - (if (file-exists-p (buffer-file-name)) - (delete-file (buffer-file-name))) - (set-buffer-modified-p nil) - (kill-buffer (buffer-name)) - (message "") - (if config - (set-window-configuration config))) - (error "Message not killed"))) - - -(defun mh-recenter (arg) - ;; Like recenter but with two improvements: nil arg means recenter, - ;; and only does anything if the current buffer is in the selected - ;; window. (Commands like save-some-buffers can make this false.) - (if (eql (get-buffer-window (current-buffer)) - (selected-window)) - (recenter (if arg arg '(t))))) - - - -;;; Commands to manipulate sequences. Sequences are stored in an alist -;;; of the form: -;;; ((seq-name msgs ...) (seq-name msgs ...) ...) - -(defun mh-make-seq (name msgs) (cons name msgs)) - -(defmacro mh-seq-name (pair) (list 'car pair)) - -(defmacro mh-seq-msgs (pair) (list 'cdr pair)) - -(defun mh-find-seq (name) (assoc name mh-seq-list)) - - -(defun mh-seq-to-msgs (seq) - "Return a list of the messages in SEQUENCE." - (mh-seq-msgs (mh-find-seq seq))) - - -(defun mh-seq-containing-msg (msg) - ;; Return a list of the sequences containing MESSAGE. - (let ((l mh-seq-list) - (seqs ())) - (while l - (if (memq msg (mh-seq-msgs (car l))) - (mh-push (mh-seq-name (car l)) seqs)) - (setq l (cdr l))) - seqs)) - - -(defun mh-msg-to-seq (msg) - ;; Given a MESSAGE number, return the first sequence in which it occurs. - (car (mh-seq-containing-msg msg))) - - -(defun mh-read-seq-default (prompt not-empty) - ;; Read and return sequence name with default narrowed or previous sequence. - (mh-read-seq prompt not-empty (or mh-narrowed-to-seq mh-previous-seq))) - - -(defun mh-read-seq (prompt not-empty &optional default) - ;; Read and return a sequence name. Prompt with PROMPT, raise an error - ;; if the sequence is empty and the NOT-EMPTY flag is non-nil, and supply - ;; an optional DEFAULT sequence. - ;; A reply of '%' defaults to the first sequence containing the current - ;; message. - (let* ((input (completing-read (format "%s %s %s" prompt "sequence:" - (if default - (format "[%s] " default) - "")) - (mh-seq-names mh-seq-list))) - (seq (cond ((equal input "%") (mh-msg-to-seq (mh-get-msg-num t))) - ((equal input "") default) - (t (intern input)))) - (msgs (mh-seq-to-msgs seq))) - (if (and (null msgs) not-empty) - (error (format "No messages in sequence `%s'" seq))) - seq)) - - -(defun mh-read-folder-sequences (folder define-sequences) - ;; Read and return the predefined sequences for a FOLDER. If - ;; DEFINE-SEQUENCES is non-nil, then define mh-e's sequences before - ;; reading MH's sequences. - (let ((seqs ())) - (mh-when define-sequences - (mh-define-sequences mh-seq-list) - (mh-mapc (function (lambda (seq) ; Save the internal sequences - (if (mh-folder-name-p (mh-seq-name seq)) - (mh-push seq seqs)))) - mh-seq-list)) - (save-excursion - (mh-exec-cmd-quiet " *mh-temp*" "mark" folder "-list") - (goto-char (point-min)) - ;; look for name in line of form "cur: 4" or "myseq (private): 23" - (while (re-search-forward "^[^: ]+" nil t) - (mh-push (mh-make-seq (intern (buffer-substring (match-beginning 0) - (match-end 0))) - (mh-read-msg-list)) - seqs)) - (delete-region (point-min) (point))) ; avoid race with mh-process-daemon - seqs)) - - -(defun mh-seq-names (seq-list) - ;; Return an alist containing the names of the SEQUENCES. - (mapcar (function (lambda (entry) (list (symbol-name (mh-seq-name entry))))) - seq-list)) - - -(defun mh-seq-from-command (folder seq seq-command) - ;; In FOLDER, make a sequence named SEQ by executing COMMAND. - ;; COMMAND is a list. The first element is a program name - ;; and the subsequent elements are its arguments, all strings. - (let ((msg) - (msgs ()) - (case-fold-search t)) - (save-excursion - (save-window-excursion - (apply 'mh-exec-cmd-quiet " *mh-temp*" seq-command) - (goto-char (point-min)) - (while (setq msg (car (mh-read-msg-list))) - (mh-push msg msgs) - (forward-line 1))) - (set-buffer folder) - (setq msgs (nreverse msgs)) ; Put in ascending order - (mh-push (mh-make-seq seq msgs) mh-seq-list) - msgs))) - - -(defun mh-read-msg-list () - ;; Return a list of message numbers from the current point to the end of - ;; the line. - (let ((msgs ()) - (end-of-line (save-excursion (end-of-line) (point))) - num) - (while (re-search-forward "[0-9]+" end-of-line t) - (setq num (string-to-int (buffer-substring (match-beginning 0) - (match-end 0)))) - (cond ((looking-at "-") ; Message range - (forward-char 1) - (re-search-forward "[0-9]+" end-of-line t) - (let ((num2 (string-to-int (buffer-substring (match-beginning 0) - (match-end 0))))) - (if (< num2 num) - (error "Bad message range: %d-%d" num num2)) - (while (<= num num2) - (mh-push num msgs) - (setq num (1+ num))))) - ((not (zerop num)) (mh-push num msgs)))) - msgs)) - - -(defun mh-remove-seq (seq) - ;; Delete the SEQUENCE. - (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq seq ? (1+ mh-cmd-note) seq) - (mh-undefine-sequence seq (list "all")) - (mh-delete-seq-locally seq)) - - -(defun mh-delete-seq-locally (seq) - ;; Remove mh-e's record of SEQUENCE. - (let ((entry (mh-find-seq seq))) - (setq mh-seq-list (delq entry mh-seq-list)))) - - -(defun mh-remove-msg-from-seq (msg seq &optional internal-flag) - ;; Remove MESSAGE from the SEQUENCE. If optional FLAG is non-nil, do not - ;; inform MH of the change. - (let ((entry (mh-find-seq seq))) - (mh-when entry - (mh-notate-if-in-one-seq msg ? (1+ mh-cmd-note) (mh-seq-name entry)) - (if (not internal-flag) - (mh-undefine-sequence seq (list msg))) - (setcdr entry (delq msg (mh-seq-msgs entry)))))) - - -(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) - ;; Add MESSAGE(s) to the SEQUENCE. If optional FLAG is non-nil, do not mark - ;; the message in the scan listing or inform MH of the addition. - (let ((entry (mh-find-seq seq))) - (if (and msgs (atom msgs)) (setq msgs (list msgs))) - (if (null entry) - (mh-push (mh-make-seq seq msgs) mh-seq-list) - (if msgs (setcdr entry (append msgs (cdr entry))))) - (mh-when (not internal-flag) - (mh-add-to-sequence seq msgs) - (mh-notate-seq seq ?% (1+ mh-cmd-note))))) - - -(defun mh-rename-seq (seq new-name) - "Rename a SEQUENCE to have a new NAME." - (interactive "SOld sequence name: \nSNew name: ") - (let ((old-seq (mh-find-seq seq))) - (if old-seq - (rplaca old-seq new-name) - (error "Sequence %s does not exists" seq)) - (mh-undefine-sequence seq (mh-seq-msgs old-seq)) - (mh-define-sequence new-name (mh-seq-msgs old-seq)))) - - -(defun mh-notate-user-sequences () - ;; Mark the scan listing of all messages in user-defined sequences. - (let ((seqs mh-seq-list) - name) - (while seqs - (setq name (mh-seq-name (car seqs))) - (if (not (mh-internal-seq name)) - (mh-notate-seq name ?% (1+ mh-cmd-note))) - (setq seqs (cdr seqs))))) - - -(defun mh-internal-seq (name) - ;; Return non-NIL if NAME is the name of an internal mh-e sequence. - (or (memq name '(answered cur deleted forwarded printed)) - (eq name mh-unseen-seq) - (mh-folder-name-p name))) - - -(defun mh-folder-name-p (name) - ;; Return non-NIL if NAME is possibly the name of a folder. - ;; A name (a string or symbol) can be a folder name if it begins with "+". - (if (symbolp name) - (eql (aref (symbol-name name) 0) ?+) - (eql (aref name 0) ?+))) - - -(defun mh-notate-seq (seq notation offset) - ;; Mark the scan listing of all messages in the SEQUENCE with the CHARACTER - ;; at the given OFFSET from the beginning of the listing line. - (mh-map-to-seq-msgs 'mh-notate seq notation offset)) - - -(defun mh-notate-if-in-one-seq (msg notation offset seq) - ;; If the MESSAGE is in only the SEQUENCE, then mark the scan listing of the - ;; message with the CHARACTER at the given OFFSET from the beginning of the - ;; listing line. - (let ((in-seqs (mh-seq-containing-msg msg))) - (if (and (eq seq (car in-seqs)) (null (cdr in-seqs))) - (mh-notate msg notation offset)))) - - -(defun mh-map-to-seq-msgs (func seq &rest args) - ;; Invoke the FUNCTION at each message in the SEQUENCE, passing the - ;; remaining ARGS as arguments. - (save-excursion - (let ((msgs (mh-seq-to-msgs seq))) - (while msgs - (if (mh-goto-msg (car msgs) t t) - (apply func (car msgs) args)) - (setq msgs (cdr msgs)))))) - - -(defun mh-map-over-seqs (func seq-list) - ;; Apply the FUNCTION to each element in the list of SEQUENCES, - ;; passing the sequence name and the list of messages as arguments. - (while seq-list - (funcall func (mh-seq-name (car seq-list)) (mh-seq-msgs (car seq-list))) - (setq seq-list (cdr seq-list)))) - - -(defun mh-define-sequences (seq-list) - ;; Define the sequences in SEQ-LIST. - (mh-map-over-seqs 'mh-define-sequence seq-list)) - - -(defun mh-add-to-sequence (seq msgs) - ;; Add to a SEQUENCE each message the list of MSGS. - (if (not (mh-folder-name-p seq)) - (if msgs - (apply 'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name seq) - "-add" msgs)))) - - -(defun mh-define-sequence (seq msgs) - ;; Define the SEQUENCE to contain the list of MSGS. Do not mark - ;; pseudo-sequences or empty sequences. - (if (and msgs - (not (mh-folder-name-p seq))) - (save-excursion - (apply 'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name seq) - "-add" "-zero" (mh-list-to-string msgs))))) - - -(defun mh-undefine-sequence (seq msgs) - ;; Remove from the SEQUENCE the list of MSGS. - (apply 'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name seq) - "-delete" msgs)) - - -(defun mh-copy-seq-to-point (seq location) - ;; Copy the scan listing of the messages in SEQUENCE to after the point - ;; LOCATION in the current buffer. - (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location)) - - -(defun mh-copy-line-to-point (msg location) - ;; Copy the current line to the LOCATION in the current buffer. - (beginning-of-line) - (let ((beginning-of-line (point))) - (forward-line 1) - (copy-region-as-kill beginning-of-line (point)) - (goto-char location) - (yank) - (goto-char beginning-of-line))) - - - -;;; Issue commands to MH. - -(defun mh-exec-cmd (command &rest args) - ;; Execute MH command COMMAND with ARGS. - ;; Any output is assumed to be an error and is shown to the user. - (save-excursion - (set-buffer " *mh-temp*") - (erase-buffer) - (apply 'call-process - (expand-file-name command mh-progs) nil t nil - (mh-list-to-string args)) - (if (> (buffer-size) 0) - (save-window-excursion - (switch-to-buffer-other-window " *mh-temp*") - (sit-for 5))))) - - -(defun mh-exec-cmd-quiet (buffer command &rest args) - ;; In BUFFER, execute MH command COMMAND with ARGS. - ;; ARGS is a list of strings. Return in BUFFER, if one exists. - (mh-when (stringp buffer) - (set-buffer buffer) - (erase-buffer)) - (apply 'call-process - (expand-file-name command mh-progs) nil buffer nil - args)) - - -(defun mh-exec-cmd-output (command display &rest args) - ;; Execute MH command COMMAND with DISPLAY flag and ARGS putting the output - ;; into buffer after point. Set mark after inserted text. - (push-mark (point) t) - (apply 'call-process - (expand-file-name command mh-progs) nil t display - (mh-list-to-string args)) - (exchange-point-and-mark)) - - -(defun mh-exec-cmd-daemon (command &rest args) - ;; Execute MH command COMMAND with ARGS. Any output from command is - ;; displayed in an asynchronous pop-up window. - (save-excursion - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer)) - (let* ((process-connection-type nil) - (process (apply 'start-process - command nil - (expand-file-name command mh-progs) - (mh-list-to-string args)))) - (set-process-filter process 'mh-process-daemon))) - - -(defun mh-process-daemon (process output) - ;; Process daemon that puts output into a temporary buffer. - (set-buffer (get-buffer-create " *mh-temp*")) - (insert-before-markers output) - (display-buffer " *mh-temp*")) - - -(defun mh-exec-lib-cmd-output (command &rest args) - ;; Execute MH library command COMMAND with ARGS. - ;; Put the output into buffer after point. Set mark after inserted text. - (push-mark (point) t) - (apply 'call-process - (expand-file-name command mh-lib) nil t nil - (mh-list-to-string args)) - (exchange-point-and-mark)) - - -(defun mh-list-to-string (l) - ;; Flattens the list L and makes every element of the new list into a string. - (let ((new-list nil)) - (while l - (cond ((null (car l))) - ((symbolp (car l)) (mh-push (symbol-name (car l)) new-list)) - ((numberp (car l)) (mh-push (int-to-string (car l)) new-list)) - ((equal (car l) "")) - ((stringp (car l)) (mh-push (car l) new-list)) - ((listp (car l)) - (setq new-list (nconc (nreverse (mh-list-to-string (car l))) - new-list))) - (t (error "Bad element in mh-list-to-string: %s" (car l)))) - (setq l (cdr l))) - (nreverse new-list))) - - - -;;; Commands to annotate a message. - -(defun mh-annotate-msg (msg buffer note &rest args) - ;; Mark the MESSAGE in BUFFER listing with the character NOTE and annotate - ;; the saved message with ARGS. - (apply 'mh-exec-cmd "anno" buffer msg args) - (save-excursion - (cond ((get-buffer buffer) ; Buffer may be deleted - (set-buffer buffer) - (if (symbolp msg) - (mh-notate-seq msg note (1+ mh-cmd-note)) - (mh-notate msg note (1+ mh-cmd-note))))))) - - -(defun mh-notate (msg notation offset) - ;; Marks MESSAGE with the character NOTATION at position OFFSET. - ;; Null MESSAGE means the message that the cursor points to. - (save-excursion - (if (or (null msg) - (mh-goto-msg msg t t)) - (with-mh-folder-updating (t) - (beginning-of-line) - (forward-char offset) - (delete-char 1) - (insert notation))))) - - - -;;; User prompting commands. - -(defun mh-prompt-for-folder (prompt default can-create) - ;; Prompt for a folder name with PROMPT. Returns the folder's name as a - ;; string. DEFAULT is used if the folder exists and the user types return. - ;; If the CAN-CREATE flag is t, then a non-existent folder is made. - (let* ((prompt (format "%s folder%s" prompt - (if (equal "" default) - "? " - (format " [%s]? " default)))) - name) - (if (null mh-folder-list) - (mh-set-folder-list)) - (while (and (setq name (completing-read prompt mh-folder-list - nil nil "+")) - (equal name "") - (equal default ""))) - (cond ((or (equal name "") (equal name "+")) - (setq name default)) - ((not (mh-folder-name-p name)) - (setq name (format "+%s" name)))) - (let ((new-file-p (not (file-exists-p (mh-expand-file-name name))))) - (cond ((and new-file-p - (y-or-n-p - (format "Folder %s does not exist. Create it? " name))) - (message "Creating %s" name) - (call-process "mkdir" nil nil nil (mh-expand-file-name name)) - (message "Creating %s...done" name) - (mh-push (list name) mh-folder-list)) - (new-file-p - (error "Folder %s is not created" name)) - (t - (mh-when (null (assoc name mh-folder-list)) - (mh-push (list name) mh-folder-list))))) - name)) - - -(defun mh-set-folder-list () - "Sets mh-folder-list correctly. -A useful function for the command line or for when you need to sync by hand." - (setq mh-folder-list (mh-make-folder-list))) - - -(defun mh-make-folder-list () - "Return a list of the user's folders. -Result is in a form suitable for completing read." - (interactive) - (message "Collecting folder names...") - (save-window-excursion - (mh-exec-cmd-quiet " *mh-temp*" "folders" "-fast" - (if mh-recursive-folders - "-recurse" - "-norecurse")) - (goto-char (point-min)) - (let ((list nil) - start) - (while (not (eobp)) - (setq start (point)) - (forward-line 1) - (mh-push (list (format "+%s" (buffer-substring start (1- (point))))) - list)) - (message "Collecting folder names...done") - list))) - - -(defun mh-remove-folder-from-folder-list (folder) - ;; Remove FOLDER from the list of folders. - (setq mh-folder-list - (delq (assoc folder mh-folder-list) mh-folder-list))) - - -(defun mh-read-msg-range (prompt) - ;; Read a list of blank-separated items. - (let* ((buf (read-string prompt)) - (buf-size (length buf)) - (start 0) - (input ())) - (while (< start buf-size) - (let ((next (read-from-string buf start buf-size))) - (mh-push (car next) input) - (setq start (cdr next)))) - (nreverse input))) - - - -;;; Misc. functions. - -(defun mh-get-msg-num (error-if-no-message) - ;; Return the message number of the displayed message. If the argument - ;; ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is not - ;; pointing to a message. - (save-excursion - (beginning-of-line) - (cond ((looking-at mh-msg-number-regexp) - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (error-if-no-message - (error "Cursor not pointing to message")) - (t nil)))) - - -(defun mh-msg-search-pat (n) - ;; Return a search pattern for message N in the scan listing. - (format mh-msg-search-regexp n)) - - -(defun mh-msg-filename (msg &optional folder) - ;; Return the file name of MESSAGE in FOLDER (default current folder). - (expand-file-name (int-to-string msg) - (if folder - (mh-expand-file-name folder) - mh-folder-filename))) - - -(defun mh-msg-filenames (msgs &optional folder) - ;; Return a list of file names for MSGS in FOLDER (default current folder). - (mapconcat (function (lambda (msg) (mh-msg-filename msg folder))) msgs " ")) - - -(defun mh-expand-file-name (filename &optional default) - "Just like `expand-file-name', but also handles MH folder names. -Assumes that any filename that starts with '+' is a folder name." - (if (mh-folder-name-p filename) - (expand-file-name (substring filename 1) mh-user-path) - (expand-file-name filename default))) - - -(defun mh-find-path () - ;; Set mh-user-path, mh-draft-folder, and mh-unseen-seq from profile file. - (save-excursion - ;; Be sure profile is fully expanded before switching buffers - (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile")))) - (if (not (file-exists-p profile)) - (error "Cannot find MH profile %s" profile)) - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer) - (insert-file-contents profile) - (setq mh-draft-folder (mh-get-field "Draft-Folder:")) - (cond ((equal mh-draft-folder "") - (setq mh-draft-folder nil)) - ((not (mh-folder-name-p mh-draft-folder)) - (setq mh-draft-folder (format "+%s" mh-draft-folder)))) - (setq mh-user-path (mh-get-field "Path:")) - (if (equal mh-user-path "") - (setq mh-user-path "Mail")) - (setq mh-user-path - (file-name-as-directory - (expand-file-name mh-user-path (expand-file-name "~")))) - (if (and mh-draft-folder - (not (file-exists-p (mh-expand-file-name mh-draft-folder)))) - (error "Draft folder %s does not exist. Create it and try again." - mh-draft-folder)) - (setq mh-unseen-seq (mh-get-field "Unseen-Sequence:")) - (if (equal mh-unseen-seq "") - (setq mh-unseen-seq 'unseen) - (setq mh-unseen-seq (intern mh-unseen-seq)))))) - - -(defun mh-get-field (field) - ;; Find and return the value of field FIELD in the current buffer. - ;; Returns the empty string if the field is not in the message. - (let ((case-fold-search t)) - (goto-char (point-min)) - (cond ((not (re-search-forward (format "^%s" field) nil t)) "") - ((looking-at "[\t ]*$") "") - (t - (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t) - (let ((start (match-beginning 1))) - (forward-line 1) - (while (looking-at "[ \t]") - (forward-line 1)) - (buffer-substring start (1- (point)))))))) - - -(defun mh-insert-fields (&rest name-values) - ;; Insert the NAME-VALUE pairs in the current buffer. - ;; Do not insert any pairs whose value is the empty string. - (let ((case-fold-search t)) - (while name-values - (let ((field-name (car name-values)) - (value (car (cdr name-values)))) - (mh-when (not (equal value "")) - (goto-char (point-min)) - (cond ((not (re-search-forward (format "^%s" field-name) nil t)) - (mh-goto-header-end 0) - (insert field-name " " value "\n")) - (t - (end-of-line) - (insert " " value)))) - (setq name-values (cdr (cdr name-values))))))) - - -(defun mh-position-on-field (field set-mark) - ;; Set point to the end of the line beginning with FIELD. - ;; Set the mark to the old value of point, if SET-MARK is non-nil. - ;; Returns non-nil iff the field was found. - (let ((case-fold-search t)) - (if set-mark (push-mark)) - (goto-char (point-min)) - (mh-goto-header-end 0) - (if (re-search-backward (format "^%s" field) nil t) - (progn (end-of-line) t) - nil))) - - -(defun mh-goto-header-end (arg) - ;; Find the end of the message header in the current buffer and position - ;; the cursor at the ARG'th newline after the header. - (if (re-search-forward "^$\\|^-+$" nil nil) - (forward-line arg))) - - - -;;; Build the folder-mode keymap: - -(suppress-keymap mh-folder-mode-map) -(define-key mh-folder-mode-map "q" 'mh-quit) -(define-key mh-folder-mode-map "b" 'mh-quit) -(define-key mh-folder-mode-map "?" 'mh-msg-is-in-seq) -(define-key mh-folder-mode-map "%" 'mh-put-msg-in-seq) -(define-key mh-folder-mode-map "|" 'mh-pipe-msg) -(define-key mh-folder-mode-map "\ea" 'mh-edit-again) -(define-key mh-folder-mode-map "\e%" 'mh-delete-msg-from-seq) -(define-key mh-folder-mode-map "\C-xn" 'mh-narrow-to-seq) -(define-key mh-folder-mode-map "\C-xw" 'mh-widen) -(define-key mh-folder-mode-map "\eb" 'mh-burst-digest) -(define-key mh-folder-mode-map "\eu" 'mh-undo-folder) -(define-key mh-folder-mode-map "\e " 'mh-page-digest) -(define-key mh-folder-mode-map "\e\177" 'mh-page-digest-backwards) -(define-key mh-folder-mode-map "\ee" 'mh-extract-rejected-mail) -(define-key mh-folder-mode-map "\ef" 'mh-visit-folder) -(define-key mh-folder-mode-map "\ek" 'mh-kill-folder) -(define-key mh-folder-mode-map "\el" 'mh-list-folders) -(define-key mh-folder-mode-map "\en" 'mh-unshar-msg) -(define-key mh-folder-mode-map "\eo" 'mh-write-msg-to-file) -(define-key mh-folder-mode-map "\ep" 'mh-pack-folder) -(define-key mh-folder-mode-map "\es" 'mh-search-folder) -(define-key mh-folder-mode-map "\er" 'mh-rescan-folder) -(define-key mh-folder-mode-map "l" 'mh-print-msg) -(define-key mh-folder-mode-map "t" 'mh-toggle-showing) -(define-key mh-folder-mode-map "c" 'mh-copy-msg) -(define-key mh-folder-mode-map ">" 'mh-write-msg-to-file) -(define-key mh-folder-mode-map "i" 'mh-inc-folder) -(define-key mh-folder-mode-map "x" 'mh-execute-commands) -(define-key mh-folder-mode-map "e" 'mh-execute-commands) -(define-key mh-folder-mode-map "r" 'mh-redistribute) -(define-key mh-folder-mode-map "f" 'mh-forward) -(define-key mh-folder-mode-map "s" 'mh-send) -(define-key mh-folder-mode-map "m" 'mh-send) -(define-key mh-folder-mode-map "a" 'mh-reply) -(define-key mh-folder-mode-map "j" 'mh-goto-msg) -(define-key mh-folder-mode-map "<" 'mh-first-msg) -(define-key mh-folder-mode-map "g" 'mh-goto-msg) -(define-key mh-folder-mode-map "\177" 'mh-previous-page) -(define-key mh-folder-mode-map " " 'mh-page-msg) -(define-key mh-folder-mode-map "." 'mh-show) -(define-key mh-folder-mode-map "u" 'mh-undo) -(define-key mh-folder-mode-map "!" 'mh-refile-or-write-again) -(define-key mh-folder-mode-map "^" 'mh-refile-msg) -(define-key mh-folder-mode-map "d" 'mh-delete-msg) -(define-key mh-folder-mode-map "\C-d" 'mh-delete-msg-no-motion) -(define-key mh-folder-mode-map "p" 'mh-previous-undeleted-msg) -(define-key mh-folder-mode-map "n" 'mh-next-undeleted-msg) -(define-key mh-folder-mode-map "o" 'mh-refile-msg) - - -;;; Build the letter-mode keymap: - -(define-key mh-letter-mode-map "\C-c\C-f\C-b" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-c" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-f" 'mh-to-fcc) -(define-key mh-letter-mode-map "\C-c\C-f\C-s" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-t" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-fb" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-fc" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-ff" 'mh-to-fcc) -(define-key mh-letter-mode-map "\C-c\C-fs" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-ft" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-q" 'mh-fully-kill-draft) -(define-key mh-letter-mode-map "\C-c\C-w" 'mh-check-whom) -(define-key mh-letter-mode-map "\C-c\C-i" 'mh-insert-letter) -(define-key mh-letter-mode-map "\C-c\C-y" 'mh-yank-cur-msg) -(define-key mh-letter-mode-map "\C-c\C-s" 'mh-insert-signature) -(define-key mh-letter-mode-map "\C-c\C-c" 'mh-send-letter) - - -;;; Build the pick-mode keymap: - -(define-key mh-pick-mode-map "\C-c\C-c" 'mh-do-pick-search) -(define-key mh-pick-mode-map "\C-c\C-f\C-b" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-c" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-f" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-s" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-t" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fb" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fc" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-ff" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fs" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-ft" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-w" 'mh-check-whom) - - - -;;; For Gnu Emacs. -;;; Local Variables: *** -;;; eval: (put 'mh-when 'lisp-indent-hook 1) *** -;;; eval: (put 'with-mh-folder-updating 'lisp-indent-hook 1) *** -;;; End: *** - -(provide 'mh-e) - -;;; mh-e.el ends here
--- a/lisp/=mhspool.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,490 +0,0 @@ -;;; mhspool.el --- MH folder access using NNTP for GNU Emacs - -;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Maintainer: FSF -;; Keywords: mail, news - -;; 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: - -;; This package enables you to read mail or articles in MH folders, or -;; articles saved by GNUS. In any case, the file names of mail or -;; articles must consist of only numeric letters. - -;; Before using this package, you have to create a server specific -;; startup file according to the directory which you want to read. For -;; example, if you want to read mail under the directory named -;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is -;; no way to specify hierarchical directory now.) In this case, the -;; name of the NNTP server passed to GNUS must be `:Mail'. - -;;; Code: - -(require 'nntp) - -(defvar mhspool-list-folders-method - (function mhspool-list-folders-using-sh) - "*Function to list files in folders. -The function should accept a directory as its argument, and fill the -current buffer with file and directory names. The output format must -be the same as that of 'ls -R1'. Two functions -mhspool-list-folders-using-ls and mhspool-list-folders-using-sh are -provided now. I suppose the later is faster.") - -(defvar mhspool-list-directory-switches '("-R") - "*Switches for mhspool-list-folders-using-ls to pass to `ls' for getting file lists. -One entry should appear on one line. You may need to add `-1' option.") - - - -(defconst mhspool-version "MHSPOOL 1.8" - "Version numbers of this version of MHSPOOL.") - -(defvar mhspool-spool-directory "~/Mail" - "Private mail directory.") - -(defvar mhspool-current-directory nil - "Current news group directory.") - -;;; -;;; Replacement of Extended Command for retrieving many headers. -;;; - -(defun mhspool-retrieve-headers (sequence) - "Return list of article headers specified by SEQUENCE of article id. -The format of list is - `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. -If there is no References: field, In-Reply-To: field is used instead. -Reader macros for the vector are defined as `nntp-header-FIELD'. -Writer macros for the vector are defined as `nntp-set-header-FIELD'. -Newsgroup must be selected before calling this." - (save-excursion - (set-buffer nntp-server-buffer) - ;;(erase-buffer) - (let ((file nil) - (number (length sequence)) - (count 0) - (headers nil) ;Result list. - (article 0) - (subject nil) - (message-id nil) - (from nil) - (xref nil) - (lines 0) - (date nil) - (references nil)) - (while sequence - ;;(nntp-send-strings-to-server "HEAD" (car sequence)) - (setq article (car sequence)) - (setq file - (concat mhspool-current-directory (prin1-to-string article))) - (if (and (file-exists-p file) - (not (file-directory-p file))) - (progn - (erase-buffer) - (insert-file-contents file) - ;; Make message body invisible. - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (narrow-to-region (point-min) (point)) - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - ;; Make it possible to search for `\nFIELD'. - (goto-char (point-min)) - (insert "\n") - ;; Extract From: - (goto-char (point-min)) - (if (search-forward "\nFrom: " nil t) - (setq from (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq from "(Unknown User)")) - ;; Extract Subject: - (goto-char (point-min)) - (if (search-forward "\nSubject: " nil t) - (setq subject (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq subject "(None)")) - ;; Extract Message-ID: - (goto-char (point-min)) - (if (search-forward "\nMessage-ID: " nil t) - (setq message-id (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq message-id nil)) - ;; Extract Date: - (goto-char (point-min)) - (if (search-forward "\nDate: " nil t) - (setq date (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq date nil)) - ;; Extract Lines: - (goto-char (point-min)) - (if (search-forward "\nLines: " nil t) - (setq lines (string-to-int - (buffer-substring - (point) - (save-excursion (end-of-line) (point))))) - ;; Count lines since there is no lines field in most cases. - (setq lines - (save-restriction - (goto-char (point-max)) - (widen) - (count-lines (point) (point-max))))) - ;; Extract Xref: - (goto-char (point-min)) - (if (search-forward "\nXref: " nil t) - (setq xref (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq xref nil)) - ;; Extract References: - ;; If no References: field, use In-Reply-To: field instead. - ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA). - (goto-char (point-min)) - (if (or (search-forward "\nReferences: " nil t) - (search-forward "\nIn-Reply-To: " nil t)) - (setq references (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq references nil)) - ;; Collect valid article only. - (and article - message-id - (setq headers - (cons (vector article subject from - xref lines date - message-id references) headers))) - )) - (setq sequence (cdr sequence)) - (setq count (1+ count)) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% count 20)) - (message "MHSPOOL: Receiving headers... %d%%" - (/ (* count 100) number))) - ) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (message "MHSPOOL: Receiving headers... done")) - (nreverse headers) - ))) - - -;;; -;;; Replacement of NNTP Raw Interface. -;;; - -(defun mhspool-open-server (host &optional service) - "Open news server on HOST. -If HOST is nil, use value of environment variable `NNTPSERVER'. -If optional argument SERVICE is non-nil, open by the service name." - (let ((host (or host (getenv "NNTPSERVER"))) - (status nil)) - ;; Get directory name from HOST name. - (if (string-match ":\\(.+\\)$" host) - (progn - (setq mhspool-spool-directory - (file-name-as-directory - (expand-file-name - (substring host (match-beginning 1) (match-end 1)) - (expand-file-name "~/" nil)))) - (setq host (system-name))) - (setq mhspool-spool-directory nil)) - (setq nntp-status-string "") - (cond ((and (stringp host) - (stringp mhspool-spool-directory) - (file-directory-p mhspool-spool-directory) - (string-equal host (system-name))) - (setq status (mhspool-open-server-internal host service))) - ((string-equal host (system-name)) - (setq nntp-status-string - (format "No such directory: %s. Goodbye." - mhspool-spool-directory))) - ((null host) - (setq nntp-status-string "NNTP server is not specified.")) - (t - (setq nntp-status-string - (format "MHSPOOL: cannot talk to %s." host))) - ) - status - )) - -(defun mhspool-close-server () - "Close news server." - (mhspool-close-server-internal)) - -(fset 'mhspool-request-quit (symbol-function 'mhspool-close-server)) - -(defun mhspool-server-opened () - "Return server process status, T or NIL. -If the stream is opened, return T, otherwise return NIL." - (and nntp-server-buffer - (get-buffer nntp-server-buffer))) - -(defun mhspool-status-message () - "Return server status response as string." - nntp-status-string - ) - -(defun mhspool-request-article (id) - "Select article by message ID (or number)." - (let ((file (concat mhspool-current-directory (prin1-to-string id)))) - (if (and (stringp file) - (file-exists-p file) - (not (file-directory-p file))) - (save-excursion - (mhspool-find-file file))) - )) - -(defun mhspool-request-body (id) - "Select article body by message ID (or number)." - (if (mhspool-request-article id) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (delete-region (point-min) (point))) - t - ) - )) - -(defun mhspool-request-head (id) - "Select article head by message ID (or number)." - (if (mhspool-request-article id) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (delete-region (1- (point)) (point-max))) - t - ) - )) - -(defun mhspool-request-stat (id) - "Select article by message ID (or number)." - (setq nntp-status-string "MHSPOOL: STAT is not implemented.") - nil - ) - -(defun mhspool-request-group (group) - "Select news GROUP." - (cond ((file-directory-p - (mhspool-article-pathname group)) - ;; Mail/NEWS.GROUP/N - (setq mhspool-current-directory - (mhspool-article-pathname group))) - ((file-directory-p - (mhspool-article-pathname - (mhspool-replace-chars-in-string group ?. ?/))) - ;; Mail/NEWS/GROUP/N - (setq mhspool-current-directory - (mhspool-article-pathname - (mhspool-replace-chars-in-string group ?. ?/)))) - )) - -(defun mhspool-request-list () - "List active newsgoups." - (save-excursion - (let* ((newsgroup nil) - (articles nil) - (directory (file-name-as-directory - (expand-file-name mhspool-spool-directory nil))) - (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$")) - (buffer (get-buffer-create " *MHSPOOL File List*"))) - (set-buffer nntp-server-buffer) - (erase-buffer) - (set-buffer buffer) - (erase-buffer) -;; (apply 'call-process -;; "ls" nil t nil -;; (append mhspool-list-directory-switches (list directory))) - (funcall mhspool-list-folders-method directory) - (goto-char (point-min)) - (while (re-search-forward folder-regexp nil t) - (setq newsgroup - (mhspool-replace-chars-in-string - (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.)) - (setq articles nil) - (forward-line 1) ;(beginning-of-line) - ;; Thank nobu@flab.fujitsu.junet for his bug fixes. - (while (and (not (eobp)) - (not (looking-at "^$"))) - (if (looking-at "^[0-9]+$") - (setq articles - (cons (string-to-int - (buffer-substring - (match-beginning 0) (match-end 0))) - articles))) - (forward-line 1)) - (if articles - (princ (format "%s %d %d n\n" newsgroup - (apply (function max) articles) - (apply (function min) articles)) - nntp-server-buffer)) - ) - (kill-buffer buffer) - (set-buffer nntp-server-buffer) - (buffer-size) - ))) - -(defun mhspool-request-list-newsgroups () - "List newsgoups (defined in NNTP2)." - (setq nntp-status-string "MHSPOOL: LIST NEWSGROUPS is not implemented.") - nil - ) - -(defun mhspool-request-list-distributions () - "List distributions (defined in NNTP2)." - (setq nntp-status-string "MHSPOOL: LIST DISTRIBUTIONS is not implemented.") - nil - ) - -(defun mhspool-request-last () - "Set current article pointer to the previous article -in the current news group." - (setq nntp-status-string "MHSPOOL: LAST is not implemented.") - nil - ) - -(defun mhspool-request-next () - "Advance current article pointer." - (setq nntp-status-string "MHSPOOL: NEXT is not implemented.") - nil - ) - -(defun mhspool-request-post () - "Post a new news in current buffer." - (setq nntp-status-string "MHSPOOL: POST: what do you mean?") - nil - ) - - -;;; -;;; Replacement of Low-Level Interface to NNTP Server. -;;; - -(defun mhspool-open-server-internal (host &optional service) - "Open connection to news server on HOST by SERVICE (default is nntp)." - (save-excursion - (if (not (string-equal host (system-name))) - (error "MHSPOOL: cannot talk to %s." host)) - ;; Initialize communication buffer. - (setq nntp-server-buffer (get-buffer-create " *nntpd*")) - (set-buffer nntp-server-buffer) - (buffer-flush-undo (current-buffer)) - (erase-buffer) - (kill-all-local-variables) - (setq case-fold-search t) ;Should ignore case. - (setq nntp-server-process nil) - (setq nntp-server-name host) - ;; It is possible to change kanji-fileio-code in this hook. - (run-hooks 'nntp-server-hook) - t - )) - -(defun mhspool-close-server-internal () - "Close connection to news server." - (if nntp-server-buffer - (kill-buffer nntp-server-buffer)) - (setq nntp-server-buffer nil) - (setq nntp-server-process nil)) - -(defun mhspool-find-file (file) - "Insert FILE in server buffer safely." - (set-buffer nntp-server-buffer) - (erase-buffer) - (condition-case () - (progn - (insert-file-contents file) - (goto-char (point-min)) - ;; If there is no body, `^L' appears at end of file. Special - ;; hack for MH folder. - (and (search-forward "\n\n" nil t) - (string-equal (buffer-substring (point) (point-max)) "\^L") - (delete-char 1)) - t - ) - (file-error nil) - )) - -(defun mhspool-article-pathname (group) - "Make pathname for GROUP." - (concat (file-name-as-directory mhspool-spool-directory) group "/")) - -(defun mhspool-replace-chars-in-string (string from to) - "Replace characters in STRING from FROM to TO." - (let ((string (substring string 0)) ;Copy string. - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (if (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string - )) - - -;; Methods for listing files in folders. - -(defun mhspool-list-folders-using-ls (directory) - "List files in folders under DIRECTORY using 'ls'." - (apply 'call-process - "ls" nil t nil - (append mhspool-list-directory-switches (list directory)))) - -;; Basic ideas by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA) - -(defun mhspool-list-folders-using-sh (directory) - "List files in folders under DIRECTORY using '/bin/sh'." - (let ((buffer (current-buffer)) - (script (get-buffer-create " *MHSPOOL Shell Script Buffer*"))) - (save-excursion - (save-restriction - (set-buffer script) - (erase-buffer) - ;; /bin/sh script which does 'ls -R'. - (insert - "PS2= - ffind() { - cd $1; echo $1: - ls -1 - echo - for j in `echo *[a-zA-Z]*` - do - if [ -d $1/$j ]; then - ffind $1/$j - fi - done - } - cd " directory "; ffind `pwd`; exit 0\n") - (call-process-region (point-min) (point-max) "sh" nil buffer nil) - )) - (kill-buffer script) - )) - -(provide 'mhspool) - -;;; mhspool.el ends here
--- a/lisp/=mim-mode.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,848 +0,0 @@ -;;; mim-mode.el --- Mim (MDL in MDL) mode. - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: languages - -;; 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. - -;;; Code: - -(autoload 'fast-syntax-check-mim "mim-syntax" - "Checks Mim syntax quickly. -Answers correct or incorrect, cannot point out the error context." - t) - -(autoload 'slow-syntax-check-mim "mim-syntax" - "Check Mim syntax slowly. -Points out the context of the error, if the syntax is incorrect." - t) - -(defvar mim-mode-hysterical-bindings t - "*Non-nil means bind list manipulation commands to Meta keys as well as -Control-Meta keys for historical reasons. Otherwise, only the latter keys -are bound.") - -(defvar mim-mode-map nil) - -(defvar mim-mode-syntax-table nil) - -(if mim-mode-syntax-table - () - (let ((i -1)) - (setq mim-mode-syntax-table (make-syntax-table)) - (while (< i ?\ ) - (modify-syntax-entry (setq i (1+ i)) " " mim-mode-syntax-table)) - (while (< i 127) - (modify-syntax-entry (setq i (1+ i)) "_ " mim-mode-syntax-table)) - (setq i (1- ?a)) - (while (< i ?z) - (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) - (setq i (1- ?A)) - (while (< i ?Z) - (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) - (setq i (1- ?0)) - (while (< i ?9) - (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) - (modify-syntax-entry ?: " " mim-mode-syntax-table) ; make : symbol delimiter - (modify-syntax-entry ?, "' " mim-mode-syntax-table) - (modify-syntax-entry ?. "' " mim-mode-syntax-table) - (modify-syntax-entry ?' "' " mim-mode-syntax-table) - (modify-syntax-entry ?` "' " mim-mode-syntax-table) - (modify-syntax-entry ?~ "' " mim-mode-syntax-table) - (modify-syntax-entry ?\; "' " mim-mode-syntax-table) ; comments are prefixed objects - (modify-syntax-entry ?# "' " mim-mode-syntax-table) - (modify-syntax-entry ?% "' " mim-mode-syntax-table) - (modify-syntax-entry ?! "' " mim-mode-syntax-table) - (modify-syntax-entry ?\" "\" " mim-mode-syntax-table) - (modify-syntax-entry ?\\ "\\ " mim-mode-syntax-table) - (modify-syntax-entry ?\( "\() " mim-mode-syntax-table) - (modify-syntax-entry ?\< "\(> " mim-mode-syntax-table) - (modify-syntax-entry ?\{ "\(} " mim-mode-syntax-table) - (modify-syntax-entry ?\[ "\(] " mim-mode-syntax-table) - (modify-syntax-entry ?\) "\)( " mim-mode-syntax-table) - (modify-syntax-entry ?\> "\)< " mim-mode-syntax-table) - (modify-syntax-entry ?\} "\){ " mim-mode-syntax-table) - (modify-syntax-entry ?\] "\)[ " mim-mode-syntax-table))) - -(defconst mim-whitespace "\000- ") - -(defvar mim-mode-hook nil - "*User function run after mim mode initialization. Usage: -\(setq mim-mode-hook '(lambda () ... your init forms ...)).") - -(define-abbrev-table 'mim-mode-abbrev-table nil) - -(defconst indent-mim-function 'indent-mim-function - "Controls (via properties) indenting of special forms. -\(put 'FOO 'indent-mim-function n\), integer n, means lines inside -<FOO ...> will be indented n spaces from start of form. -\(put 'FOO 'indent-mim-function 'DEFINE\) is like above but means use -value of mim-body-indent as offset from start of form. -\(put 'FOO 'indent-mim-function <cons>\) where <cons> is a list or pointed list -of integers, means indent each form in <FOO ...> by the amount specified -in <cons>. When <cons> is exhausted, indent remaining forms by -`mim-body-indent' unless <cons> is a pointed list, in which case the last -cdr is used. Confused? Here is an example: -\(put 'FROBIT 'indent-mim-function '\(4 2 . 1\)\) -<FROBIT - <CHOMP-IT> - <CHOMP-SOME-MORE> - <DIGEST> - <BELCH> - ...> -Finally, the property can be a function name (read the code).") - -(defvar indent-mim-comment t - "*Non-nil means indent string comments.") - -(defvar mim-body-indent 2 - "*Amount to indent in special forms which have DEFINE property on -`indent-mim-function'.") - -(defvar indent-mim-arglist t - "*nil means indent arglists like ordinary lists. -t means strings stack under start of arglist and variables stack to -right of them. Otherwise, strings stack under last string (or start -of arglist if none) and variables stack to right of them. -Examples (for values 'stack, t, nil): - -\(FOO \"OPT\" BAR \(FOO \"OPT\" BAR \(FOO \"OPT\" BAR - BAZ MUMBLE BAZ MUMBLE BAZ MUMBLE - \"AUX\" \"AUX\" \"AUX\" - BLETCH ... BLETCH ... BLETCH ...") - -(put 'DEFINE 'indent-mim-function 'DEFINE) -(put 'DEFMAC 'indent-mim-function 'DEFINE) -(put 'BIND 'indent-mim-function 'DEFINE) -(put 'PROG 'indent-mim-function 'DEFINE) -(put 'REPEAT 'indent-mim-function 'DEFINE) -(put 'CASE 'indent-mim-function 'DEFINE) -(put 'FUNCTION 'indent-mim-function 'DEFINE) -(put 'MAPF 'indent-mim-function 'DEFINE) -(put 'MAPR 'indent-mim-function 'DEFINE) -(put 'UNWIND 'indent-mim-function (cons (* 2 mim-body-indent) mim-body-indent)) - -(defvar mim-down-parens-only t - "*nil means treat ADECLs and ATOM trailers like structures when -moving down a level of structure.") - -(defvar mim-stop-for-slop t - "*Non-nil means {next previous}-mim-object consider any -non-whitespace character in column 0 to be a toplevel object, otherwise -only open paren syntax characters will be considered.") - -(defalias 'mdl-mode 'mim-mode) - -(defun mim-mode () - "Major mode for editing Mim (MDL in MDL) code. -Commands: - If value of `mim-mode-hysterical-bindings' is non-nil, then following -commands are assigned to escape keys as well (e.g. ESC f = ESC C-f). -The default action is bind the escape keys. -\\{mim-mode-map} -Other Commands: - Use \\[describe-function] to obtain documentation. - replace-in-mim-object find-mim-definition fast-syntax-check-mim - slow-syntax-check-mim backward-down-mim-object forward-up-mim-object -Variables: - Use \\[describe-variable] to obtain documentation. - mim-mode-hook indent-mim-comment indent-mim-arglist indent-mim-function - mim-body-indent mim-down-parens-only mim-stop-for-slop - mim-mode-hysterical-bindings -Entry to this mode calls the value of mim-mode-hook if non-nil." - (interactive) - (kill-all-local-variables) - (if (not mim-mode-map) - (progn - (setq mim-mode-map (make-sparse-keymap)) - (define-key mim-mode-map "\e\^o" 'open-mim-line) - (define-key mim-mode-map "\e\^q" 'indent-mim-object) - (define-key mim-mode-map "\e\^p" 'previous-mim-object) - (define-key mim-mode-map "\e\^n" 'next-mim-object) - (define-key mim-mode-map "\e\^a" 'beginning-of-DEFINE) - (define-key mim-mode-map "\e\^e" 'end-of-DEFINE) - (define-key mim-mode-map "\e\^t" 'transpose-mim-objects) - (define-key mim-mode-map "\e\^u" 'backward-up-mim-object) - (define-key mim-mode-map "\e\^d" 'forward-down-mim-object) - (define-key mim-mode-map "\e\^h" 'mark-mim-object) - (define-key mim-mode-map "\e\^k" 'forward-kill-mim-object) - (define-key mim-mode-map "\e\^f" 'forward-mim-object) - (define-key mim-mode-map "\e\^b" 'backward-mim-object) - (define-key mim-mode-map "\e^" 'raise-mim-line) - (define-key mim-mode-map "\e\\" 'fixup-whitespace) - (define-key mim-mode-map "\177" 'backward-delete-char-untabify) - (define-key mim-mode-map "\e\177" 'backward-kill-mim-object) - (define-key mim-mode-map "\^j" 'newline-and-mim-indent) - (define-key mim-mode-map "\e;" 'begin-mim-comment) - (define-key mim-mode-map "\t" 'indent-mim-line) - (define-key mim-mode-map "\e\t" 'indent-mim-object) - (if (not mim-mode-hysterical-bindings) - nil - ;; i really hate this but too many people are accustomed to these. - (define-key mim-mode-map "\e!" 'line-to-top-of-window) - (define-key mim-mode-map "\eo" 'open-mim-line) - (define-key mim-mode-map "\ep" 'previous-mim-object) - (define-key mim-mode-map "\en" 'next-mim-object) - (define-key mim-mode-map "\ea" 'beginning-of-DEFINE) - (define-key mim-mode-map "\ee" 'end-of-DEFINE) - (define-key mim-mode-map "\et" 'transpose-mim-objects) - (define-key mim-mode-map "\eu" 'backward-up-mim-object) - (define-key mim-mode-map "\ed" 'forward-down-mim-object) - (define-key mim-mode-map "\ek" 'forward-kill-mim-object) - (define-key mim-mode-map "\ef" 'forward-mim-object) - (define-key mim-mode-map "\eb" 'backward-mim-object)))) - (use-local-map mim-mode-map) - (set-syntax-table mim-mode-syntax-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) - ;; Most people use string comments. - (make-local-variable 'comment-start) - (setq comment-start ";\"") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip ";\"") - (make-local-variable 'comment-end) - (setq comment-end "\"") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'indent-mim-comment) - ;; tell generic indenter how to indent. - (make-local-variable 'indent-line-function) - (setq indent-line-function 'indent-mim-line) - ;; look for that paren - (make-local-variable 'blink-matching-paren-distance) - (setq blink-matching-paren-distance nil) - ;; so people who dont like tabs can turn them off locally in indenter. - (make-local-variable 'indent-tabs-mode) - (setq indent-tabs-mode t) - (setq local-abbrev-table mim-mode-abbrev-table) - (setq major-mode 'mim-mode) - (setq mode-name "Mim") - (run-hooks 'mim-mode-hook)) - -(defun line-to-top-of-window () - "Move current line to top of window." - (interactive) ; for lazy people - (recenter 0)) - -(defun forward-mim-object (arg) - "Move forward across Mim object. -With ARG, move forward that many objects." - (interactive "p") - ;; this function is weird because it emulates the behavior of the old - ;; (gosling) mim-mode - if the arg is 1 and we are `inside' an ADECL, - ;; more than one character into the ATOM part and not sitting on the - ;; colon, then we move to the DECL part (just past colon) instead of - ;; the end of the object (the entire ADECL). otherwise, ADECL's are - ;; atomic objects. likewise for ATOM trailers. - (if (= (abs arg) 1) - (if (inside-atom-p) - ;; Move to end of ATOM or to trailer (!) or to ADECL (:). - (forward-sexp arg) - ;; Either scan an sexp or move over one bracket. - (forward-mim-objects arg t)) - ;; in the multi-object case, don't perform any magic. - ;; treats ATOM trailers and ADECLs atomically, stops at unmatched - ;; brackets with error. - (forward-mim-objects arg))) - -(defun inside-atom-p () - ;; Returns t iff inside an atom (takes account of trailers) - (let ((c1 (preceding-char)) - (c2 (following-char))) - (and (or (= (char-syntax c1) ?w) (= (char-syntax c1) ?_) (= c1 ?!)) - (or (= (char-syntax c2) ?w) (= (char-syntax c2) ?_) (= c2 ?!))))) - -(defun forward-mim-objects (arg &optional skip-bracket-p) - ;; Move over arg objects ignoring ADECLs and trailers. If - ;; skip-bracket-p is non-nil, then move over one bracket on error. - (let ((direction (sign arg))) - (condition-case conditions - (while (/= arg 0) - (forward-sexp direction) - (if (not (inside-adecl-or-trailer-p direction)) - (setq arg (- arg direction)))) - (error (if (not skip-bracket-p) - (signal 'error (cdr conditions)) - (skip-mim-whitespace direction) - (goto-char (+ (point) direction))))) - ;; If we moved too far move back to first interesting character. - (if (= (point) (buffer-end direction)) (skip-mim-whitespace (- direction))))) - -(defun backward-mim-object (&optional arg) - "Move backward across Mim object. -With ARG, move backward that many objects." - (interactive "p") - (forward-mim-object (if arg (- arg) -1))) - -(defun mark-mim-object (&optional arg) - "Mark following Mim object. -With ARG, mark that many following (preceding, ARG < 0) objects." - (interactive "p") - (push-mark (save-excursion (forward-mim-object (or arg 1)) (point)))) - -(defun forward-kill-mim-object (&optional arg) - "Kill following Mim object. -With ARG, kill that many objects." - (interactive "*p") - (kill-region (point) (progn (forward-mim-object (or arg 1)) (point)))) - -(defun backward-kill-mim-object (&optional arg) - "Kill preceding Mim object. -With ARG, kill that many objects." - (interactive "*p") - (forward-kill-mim-object (- (or arg 1)))) - -(defun raise-mim-line (&optional arg) - "Raise following line, fixing up whitespace at join. -With ARG raise that many following lines. -A negative ARG will raise current line and previous lines." - (interactive "*p") - (let* ((increment (sign (or arg (setq arg 1)))) - (direction (if (> arg 0) 1 0))) - (save-excursion - (while (/= arg 0) - ;; move over eol and kill it - (forward-line direction) - (delete-region (point) (1- (point))) - (fixup-whitespace) - (setq arg (- arg increment)))))) - -(defun forward-down-mim-object (&optional arg) - "Move down a level of Mim structure forwards. -With ARG, move down that many levels forwards (backwards, ARG < 0)." - (interactive "p") - ;; another weirdo - going down `inside' an ADECL or ATOM trailer - ;; depends on the value of mim-down-parens-only. if nil, treat - ;; ADECLs and trailers as structured objects. - (let ((direction (sign (or arg (setq arg 1))))) - (if (and (= (abs arg) 1) (not mim-down-parens-only)) - (goto-char - (save-excursion - (skip-mim-whitespace direction) - (if (> direction 0) (re-search-forward "\\s'*")) - (or (and (let ((c (next-char direction))) - (or (= (char-syntax c) ?_) - (= (char-syntax c) ?w))) - (progn (forward-sexp direction) - (if (inside-adecl-or-trailer-p direction) - (point)))) - (scan-lists (point) direction -1) - (buffer-end direction)))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) direction -1) (buffer-end direction))) - (setq arg (- arg direction)))))) - -(defun backward-down-mim-object (&optional arg) - "Move down a level of Mim structure backwards. -With ARG, move down that many levels backwards (forwards, ARG < 0)." - (interactive "p") - (forward-down-mim-object (if arg (- arg) -1))) - -(defun forward-up-mim-object (&optional arg) - "Move up a level of Mim structure forwards -With ARG, move up that many levels forwards (backwards, ARG < 0)." - (interactive "p") - (let ((direction (sign (or arg (setq arg 1))))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) direction 1) (buffer-end arg))) - (setq arg (- arg direction))) - (if (< direction 0) (backward-prefix-chars)))) - -(defun backward-up-mim-object (&optional arg) - "Move up a level of Mim structure backwards -With ARG, move up that many levels backwards (forwards, ARG > 0)." - (interactive "p") - (forward-up-mim-object (if arg (- arg) -1))) - -(defun replace-in-mim-object (old new) - "Replace string in following Mim object." - (interactive "*sReplace in object: \nsReplace %s with: ") - (save-restriction - (narrow-to-region (point) (save-excursion (forward-mim-object 1) (point))) - (replace-string old new))) - -(defun transpose-mim-objects (&optional arg) - "Transpose Mim objects around point. -With ARG, transpose preceding object that many times with following objects. -A negative ARG will transpose backwards." - (interactive "*p") - (transpose-subr 'forward-mim-object (or arg 1))) - -(defun beginning-of-DEFINE (&optional arg move) - "Move backward to beginning of surrounding or previous toplevel Mim form. -With ARG, do it that many times. Stops at last toplevel form seen if buffer -end is reached." - (interactive "p") - (let ((direction (sign (or arg (setq arg 1))))) - (if (not move) (setq move t)) - (if (< direction 0) (goto-char (1+ (point)))) - (while (and (/= arg 0) (re-search-backward "^<" nil move direction)) - (setq arg (- arg direction))) - (if (< direction 0) - (goto-char (1- (point)))))) - -(defun end-of-DEFINE (&optional arg) - "Move forward to end of surrounding or next toplevel mim form. -With ARG, do it that many times. Stops at end of last toplevel form seen -if buffer end is reached." - (interactive "p") - (if (not arg) (setq arg 1)) - (if (< arg 0) - (beginning-of-DEFINE (- (1- arg))) - (if (not (looking-at "^<")) (setq arg (1+ arg))) - (beginning-of-DEFINE (- arg) 'move) - (beginning-of-DEFINE 1)) - (forward-mim-object 1) - (forward-line 1)) - -(defun next-mim-object (&optional arg) - "Move to beginning of next toplevel Mim object. -With ARG, do it that many times. Stops at last object seen if buffer end -is reached." - (interactive "p") - (let ((search-string (if mim-stop-for-slop "^\\S " "^\\s(")) - (direction (sign (or arg (setq arg 1))))) - (if (> direction 0) - (goto-char (1+ (point)))) ; no error if end of buffer - (while (and (/= arg 0) - (re-search-forward search-string nil t direction)) - (setq arg (- arg direction))) - (if (> direction 0) - (goto-char (1- (point)))) ; no error if beginning of buffer - ;; scroll to top of window if moving forward and end not visible. - (if (not (or (< direction 0) - (save-excursion (forward-mim-object 1) - (pos-visible-in-window-p (point))))) - (recenter 0)))) - -(defun previous-mim-object (&optional arg) - "Move to beginning of previous toplevel Mim object. -With ARG do it that many times. Stops at last object seen if buffer end -is reached." - (interactive "p") - (next-mim-object (- (or arg 1)))) - -(defun calculate-mim-indent (&optional parse-start) - "Calculate indentation for Mim line. Returns column." - (save-excursion ; some excursion, huh, toto? - (beginning-of-line) - (let ((indent-point (point)) retry state containing-sexp last-sexp - desired-indent start peek where paren-depth) - (if parse-start - (goto-char parse-start) ; should be containing environment - (catch 'from-the-top - ;; find a place to start parsing. going backwards is fastest. - ;; forward-sexp signals error on encountering unmatched open. - (setq retry t) - (while retry - (condition-case nil (forward-sexp -1) (error (setq retry nil))) - (if (looking-at ".?[ \t]*\"") - ;; cant parse backward in presence of strings, go forward. - (progn - (goto-char indent-point) - (re-search-backward "^\\s(" nil 'move 1) ; to top of object - (throw 'from-the-top nil))) - (setq retry (and retry (/= (current-column) 0)))) - (skip-chars-backward mim-whitespace) - (if (not (bobp)) (forward-char -1)) ; onto unclosed open - (backward-prefix-chars))) - ;; find outermost containing sexp if we started inside an sexp. - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) - ;; find usual column to indent under (not in string or toplevel). - ;; on termination, state will correspond to containing environment - ;; (if retry is nil), where will be position of character to indent - ;; under normally, and desired-indent will be the column to indent to - ;; except if inside form, string, or at toplevel. point will be in - ;; in column to indent to unless inside string. - (setq retry t) - (while (and retry (setq paren-depth (car state)) (> paren-depth 0)) - ;; find innermost containing sexp. - (setq retry nil) - (setq last-sexp (car (nthcdr 2 state))) - (setq containing-sexp (car (cdr state))) - (goto-char (1+ containing-sexp)) ; to last unclosed open - (if (and last-sexp (> last-sexp (point))) - ;; is the last sexp a containing sexp? - (progn (setq peek (parse-partial-sexp last-sexp indent-point 0)) - (if (setq retry (car (cdr peek))) (setq state peek)))) - (if retry - nil - (setq where (1+ containing-sexp)) ; innermost containing sexp - (goto-char where) - (cond - ((not last-sexp) ; indent-point after bracket - (setq desired-indent (current-column))) - ((= (preceding-char) ?\<) ; it's a form - (cond ((> (progn (forward-sexp 1) (point)) last-sexp) - (goto-char where)) ; only one frob - ((> (save-excursion (forward-line 1) (point)) last-sexp) - (skip-chars-forward " \t") ; last-sexp is on same line - (setq where (point))) ; as containing-sexp - ((progn - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (or (= (point) last-sexp) - (save-excursion - (= (car (parse-partial-sexp (point) last-sexp 0)) - 0)))) - (backward-prefix-chars) ; last-sexp 1st on line or 1st - (setq where (point))) ; frob on that line level 0 - (t (goto-char where)))) ; punt, should never occur - ((and indent-mim-arglist ; maybe hack arglist - (= (preceding-char) ?\() ; its a list - (save-excursion ; look for magic atoms - (setq peek 0) ; using peek as counter - (forward-char -1) ; back over containing paren - (while (and (< (setq peek (1+ peek)) 6) - (condition-case nil - (progn (forward-sexp -1) t) - (error nil)))) - (and (< peek 6) (looking-at "DEFINE\\|DEFMAC\\|FUNCTION")))) - ;; frobs stack under strings they belong to or under first - ;; frob to right of strings they belong to unless luser has - ;; frob (non-string) on preceding line with different - ;; indentation. strings stack under start of arglist unless - ;; mim-indent-arglist is not t, in which case they stack - ;; under the last string, if any, else the start of the arglist. - (let ((eol 0) last-string) - (while (< (point) last-sexp) ; find out where the strings are - (skip-chars-forward mim-whitespace last-sexp) - (if (> (setq start (point)) eol) - (progn ; simultaneously keeping track - (setq where (min where start)) - (end-of-line) ; of indentation of first frob - (setq eol (point)) ; on each line - (goto-char start))) - (if (= (following-char) ?\") - (progn (setq last-string (point)) - (forward-sexp 1) - (if (= last-string last-sexp) - (setq where last-sexp) - (skip-chars-forward mim-whitespace last-sexp) - (setq where (point)))) - (forward-sexp 1))) - (goto-char indent-point) ; if string is first on - (skip-chars-forward " \t" (point-max)) ; line we are indenting, it - (if (= (following-char) ?\") ; goes under arglist start - (if (and last-string (not (equal indent-mim-arglist t))) - (setq where last-string) ; or under last string. - (setq where (1+ containing-sexp))))) - (goto-char where) - (setq desired-indent (current-column))) - (t ; plain vanilla structure - (cond ((> (save-excursion (forward-line 1) (point)) last-sexp) - (skip-chars-forward " \t") ; last-sexp is on same line - (setq where (point))) ; as containing-sexp - ((progn - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (or (= (point) last-sexp) - (save-excursion - (= (car (parse-partial-sexp (point) last-sexp 0)) - 0)))) - (backward-prefix-chars) ; last-sexp 1st on line or 1st - (setq where (point))) ; frob on that line level 0 - (t (goto-char where))) ; punt, should never occur - (setq desired-indent (current-column)))))) - ;; state is innermost containing environment unless toplevel or string. - (if (car (nthcdr 3 state)) ; inside string - (progn - (if last-sexp ; string must be next - (progn (goto-char last-sexp) - (forward-sexp 1) - (search-forward "\"") - (forward-char -1)) - (goto-char indent-point) ; toplevel string, look for it - (re-search-backward "[^\\]\"") - (forward-char 1)) - (setq start (point)) ; opening double quote - (skip-chars-backward " \t") - (backward-prefix-chars) - ;; see if the string is really a comment. - (if (and (looking-at ";[ \t]*\"") indent-mim-comment) - ;; it's a comment, line up under the start unless disabled. - (goto-char (1+ start)) - ;; it's a string, dont mung the indentation. - (goto-char indent-point) - (skip-chars-forward " \t")) - (setq desired-indent (current-column)))) - ;; point is sitting in usual column to indent to and if retry is nil - ;; then state corresponds to containing environment. if desired - ;; indentation not determined, we are inside a form, so call hook. - (or desired-indent - (and indent-mim-function - (not retry) - (setq desired-indent - (funcall indent-mim-function state indent-point))) - (setq desired-indent (current-column))) - (goto-char indent-point) ; back to where we started - desired-indent))) ; return column to indent to - -(defun indent-mim-function (state indent-point) - "Compute indentation for Mim special forms. Returns column or nil." - (let ((containing-sexp (car (cdr state))) (current-indent (point))) - (save-excursion - (goto-char (1+ containing-sexp)) - (backward-prefix-chars) - ;; make sure we are looking at a symbol. if so, see if it is a special - ;; symbol. if so, add the special indentation to the indentation of - ;; the start of the special symbol, unless the property is not - ;; an integer and not nil (in this case, call the property, it must - ;; be a function which returns the appropriate indentation or nil and - ;; does not change the buffer). - (if (looking-at "\\sw\\|\\s_") - (let* ((start (current-column)) - (function - (intern-soft (buffer-substring (point) - (progn (forward-sexp 1) - (point))))) - (method (get function 'indent-mim-function))) - (if (or (if (equal method 'DEFINE) (setq method mim-body-indent)) - (integerp method)) - ;; only use method if its first line after containing-sexp. - ;; we could have done this in calculate-mim-indent, but someday - ;; someone might want to format frobs in a special form based - ;; on position instead of indenting uniformly (like lisp if), - ;; so preserve right for posterity. if not first line, - ;; calculate-mim-indent already knows right indentation - - ;; give luser chance to change indentation manually by changing - ;; 1st line after containing-sexp. - (if (> (progn (forward-line 1) (point)) (car (nthcdr 2 state))) - (+ method start)) - (goto-char current-indent) - (if (consp method) - ;; list or pointed list of explicit indentations - (indent-mim-offset state indent-point) - (if (and (symbolp method) (fboundp method)) - ;; luser function - s/he better know what's going on. - ;; should take state and indent-point as arguments - for - ;; description of state, see parse-partial-sexp - ;; documentation the function is guaranteed the following: - ;; (1) state describes the closest surrounding form, - ;; (2) indent-point is the beginning of the line being - ;; indented, (3) point points to char in column that would - ;; normally be used for indentation, (4) function is bound - ;; to the special ATOM. See indent-mim-offset for example - ;; of a special function. - (funcall method state indent-point))))))))) - -(defun indent-mim-offset (state indent-point) - ;; offset forms explicitly according to list of indentations. - (let ((mim-body-indent mim-body-indent) - (indentations (get function 'indent-mim-function)) - (containing-sexp (car (cdr state))) - (last-sexp (car (nthcdr 2 state))) - indentation) - (goto-char (1+ containing-sexp)) - ;; determine which of the indentations to use. - (while (and (< (point) indent-point) - (condition-case nil - (progn (forward-sexp 1) - (parse-partial-sexp (point) indent-point 1 t)) - (error nil))) - (skip-chars-backward " \t") - (backward-prefix-chars) - (if (= (following-char) ?\;) - nil ; ignore comments - (setq indentation (car indentations)) - (if (integerp (setq indentations (cdr indentations))) - ;; if last cdr is integer, that is indentation to use for all - ;; all the rest of the forms. - (progn (setq mim-body-indent indentations) - (setq indentations nil))))) - (goto-char (1+ containing-sexp)) - (+ (current-column) (or indentation mim-body-indent)))) - -(defun indent-mim-comment (&optional start) - "Indent a one line (string) Mim comment following object, if any." - (let* ((old-point (point)) (eol (progn (end-of-line) (point))) state last-sexp) - ;; this function assumes that comment indenting is enabled. it is caller's - ;; responsibility to check the indent-mim-comment flag before calling. - (beginning-of-line) - (catch 'no-comment - (setq state (parse-partial-sexp (point) eol)) - ;; determine if there is an existing regular comment. a `regular' - ;; comment is defined as a commented string which is the last thing - ;; on the line and does not extend beyond the end of the line. - (if (or (not (setq last-sexp (car (nthcdr 2 state)))) - (car (nthcdr 3 state))) - ;; empty line or inside string (multiple line). - (throw 'no-comment nil)) - ;; could be a comment, but make sure its not the only object. - (beginning-of-line) - (parse-partial-sexp (point) eol 0 t) - (if (= (point) last-sexp) - ;; only one object on line - (throw 'no-comment t)) - (goto-char last-sexp) - (skip-chars-backward " \t") - (backward-prefix-chars) - (if (not (looking-at ";[ \t]*\"")) - ;; aint no comment - (throw 'no-comment nil)) - ;; there is an existing regular comment - (delete-horizontal-space) - ;; move it to comment-column if possible else to tab-stop - (if (< (current-column) comment-column) - (indent-to comment-column) - (tab-to-tab-stop))) - (goto-char old-point))) - -(defun indent-mim-line () - "Indent line of Mim code." - (interactive "*") - (let* ((position (- (point-max) (point))) - (bol (progn (beginning-of-line) (point))) - (indent (calculate-mim-indent))) - (skip-chars-forward " \t") - (if (/= (current-column) indent) - (progn (delete-region bol (point)) (indent-to indent))) - (if (> (- (point-max) position) (point)) (goto-char (- (point-max) position))))) - -(defun newline-and-mim-indent () - "Insert newline at point and indent." - (interactive "*") - ;; commented code would correct indentation of line in arglist which - ;; starts with string, but it would indent every line twice. luser can - ;; just say tab after typing string to get same effect. - ;(if indent-mim-arglist (indent-mim-line)) - (newline) - (indent-mim-line)) - -(defun open-mim-line (&optional lines) - "Insert newline before point and indent. -With ARG insert that many newlines." - (interactive "*p") - (beginning-of-line) - (let ((indent (calculate-mim-indent))) - (while (> lines 0) - (newline) - (forward-line -1) - (indent-to indent) - (setq lines (1- lines))))) - -(defun indent-mim-object (&optional dont-indent-first-line) - "Indent object following point and all lines contained inside it. -With ARG, idents only contained lines (skips first line)." - (interactive "*P") - (let (end bol indent start) - (save-excursion (parse-partial-sexp (point) (point-max) 0 t) - (setq start (point)) - (forward-sexp 1) - (setq end (- (point-max) (point)))) - (save-excursion - (if (not dont-indent-first-line) (indent-mim-line)) - (while (progn (forward-line 1) (> (- (point-max) (point)) end)) - (setq indent (calculate-mim-indent start)) - (setq bol (point)) - (skip-chars-forward " \t") - (if (/= indent (current-column)) - (progn (delete-region bol (point)) (indent-to indent))) - (if indent-mim-comment (indent-mim-comment)))))) - -(defun find-mim-definition (name) - "Search for definition of function, macro, or gfcn. -You need type only enough of the name to be unambiguous." - (interactive "sName: ") - (let (where) - (save-excursion - (goto-char (point-min)) - (condition-case nil - (progn - (re-search-forward - (concat "^<\\(DEFINE\\|\\DEFMAC\\|FCN\\|GFCN\\)\\([ \t]*\\)" - name)) - (setq where (point))) - (error (error "Can't find %s" name)))) - (if where - (progn (push-mark) - (goto-char where) - (beginning-of-line) - (recenter 0))))) - -(defun begin-mim-comment () - "Move to existing comment or insert empty comment." - (interactive "*") - (let* ((eol (progn (end-of-line) (point))) - (bol (progn (beginning-of-line) (point)))) - ;; check for existing comment first. - (if (re-search-forward ";[ \t]*\"" eol t) - ;; found it. indent if desired and go there. - (if indent-mim-comment - (let ((where (- (point-max) (point)))) - (indent-mim-comment) - (goto-char (- (point-max) where)))) - ;; nothing there, make a comment. - (let (state last-sexp) - ;; skip past all the sexps on the line - (goto-char bol) - (while (and (equal (car (setq state (parse-partial-sexp (point) eol 0))) - 0) - (car (nthcdr 2 state))) - (setq last-sexp (car (nthcdr 2 state)))) - (if (car (nthcdr 3 state)) - nil ; inside a string, punt - (delete-region (point) eol) ; flush trailing whitespace - (if (and (not last-sexp) (equal (car state) 0)) - (indent-to (calculate-mim-indent)) ; empty, indent like code - (if (> (current-column) comment-column) ; indent to comment column - (tab-to-tab-stop) ; unless past it, else to - (indent-to comment-column))) ; tab-stop - ;; if luser changes comment-{start end} to something besides semi - ;; followed by zero or more whitespace characters followed by string - ;; delimiters, the code above fails to find existing comments, but as - ;; taa says, `let the losers lose'. - (insert comment-start) - (save-excursion (insert comment-end))))))) - -(defun skip-mim-whitespace (direction) - (if (>= direction 0) - (skip-chars-forward mim-whitespace (point-max)) - (skip-chars-backward mim-whitespace (point-min)))) - -(defun inside-adecl-or-trailer-p (direction) - (if (>= direction 0) - (looking-at ":\\|!-") - (or (= (preceding-char) ?:) - (looking-at "!-")))) - -(defun sign (n) - "Returns -1 if N < 0, else 1." - (if (>= n 0) 1 -1)) - -(defun abs (n) - "Returns the absolute value of N." - (if (>= n 0) n (- n))) - -(defun next-char (direction) - "Returns preceding-char if DIRECTION < 0, otherwise following-char." - (if (>= direction 0) (following-char) (preceding-char))) - -(provide 'mim-mode) - -;;; mim-mode.el ends here
--- a/lisp/=mim-syntax.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,95 +0,0 @@ -;;; mim-syntax.el --- syntax checker for Mim (MDL). - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: languages - -;; 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. - -;;; Code: - -(require 'mim-mode) - -(defun slow-syntax-check-mim () - "Check Mim syntax slowly. -Points out the context of the error, if the syntax is incorrect." - (interactive) - (message "checking syntax...") - (let ((stop (point-max)) point-stack current last-bracket whoops last-point) - (save-excursion - (goto-char (point-min)) - (while (and (not whoops) - (re-search-forward "\\s(\\|\\s)\\|\"\\|[\\]" stop t)) - (setq current (preceding-char)) - (cond ((= current ?\") - (condition-case nil - (progn (re-search-forward "[^\\]\"") - (setq current nil)) - (error (setq whoops (point))))) - ((= current ?\\) - (condition-case nil (forward-char 1) (error nil))) - ((= (char-syntax current) ?\)) - (if (or (not last-bracket) - (not (= (logand (lsh (aref (syntax-table) last-bracket) -8) - ?\177) - current))) - (setq whoops (point)) - (setq last-point (car point-stack)) - (setq last-bracket (if last-point (char-after (1- last-point)))) - (setq point-stack (cdr point-stack)))) - (t - (if last-point (setq point-stack (cons last-point point-stack))) - (setq last-point (point)) - (setq last-bracket current))))) - (cond ((not (or whoops last-point)) - (message "Syntax correct")) - (whoops - (goto-char whoops) - (cond ((equal current ?\") - (error "Unterminated string")) - ((not last-point) - (error "Extraneous %s" (char-to-string current))) - (t - (error "Mismatched %s with %s" - (save-excursion - (setq whoops (1- (point))) - (goto-char (1- last-point)) - (buffer-substring (point) - (min (progn (end-of-line) (point)) - whoops))) - (char-to-string current))))) - (t - (goto-char last-point) - (error "Unmatched %s" (char-to-string last-bracket)))))) - -(defun fast-syntax-check-mim () - "Checks Mim syntax quickly. -Answers correct or incorrect, cannot point out the error context." - (interactive) - (save-excursion - (goto-char (point-min)) - (let (state) - (while (and (not (eobp)) - (equal (car (setq state (parse-partial-sexp (point) (point-max) 0))) - 0))) - (if (equal (car state) 0) - (message "Syntax correct") - (error "Syntax incorrect"))))) - -;;; mim-syntax.el ends here
--- a/lisp/=netunam.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,160 +0,0 @@ -;;; netunam.el --- HP-UX RFA Commands - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Chris Hanson <cph@zurich.ai.mit.edu> -;; Keywords: comm - -;; 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: - -;; Use the Remote File Access (RFA) facility of HP-UX from Emacs. - -;;; Code: - -(defconst rfa-node-directory "/net/" - "Directory in which RFA network special files are stored. -By HP convention, this is \"/net/\".") - -(defvar rfa-default-node nil - "If not nil, this is the name of the default RFA network special file.") - -(defvar rfa-password-memoize-p t - "If non-nil, remember login user's passwords after they have been entered.") - -(defvar rfa-password-alist '() - "An association from node-name strings to password strings. -Used if `rfa-password-memoize-p' is non-nil.") - -(defvar rfa-password-per-node-p t - "If nil, login user uses same password on all machines. -Has no effect if `rfa-password-memoize-p' is nil.") - -(defun rfa-set-password (password &optional node user) - "Add PASSWORD to the RFA password database. -Optional second arg NODE is a string specifying a particular nodename; - if supplied and not nil, PASSWORD applies to only that node. -Optional third arg USER is a string specifying the (remote) user whose - password this is; if not supplied this defaults to (user-login-name)." - (if (not user) (setq user (user-login-name))) - (let ((node-entry (assoc node rfa-password-alist))) - (if node-entry - (let ((user-entry (assoc user (cdr node-entry)))) - (if user-entry - (rplacd user-entry password) - (rplacd node-entry - (nconc (cdr node-entry) - (list (cons user password)))))) - (setq rfa-password-alist - (nconc rfa-password-alist - (list (list node (cons user password)))))))) - -(defun rfa-open (node &optional user password) - "Open a network connection to a server using remote file access. -First argument NODE is the network node for the remote machine. -Second optional argument USER is the user name to use on that machine. - If called interactively, the user name is prompted for. -Third optional argument PASSWORD is the password string for that user. - If not given, this is filled in from the value of -`rfa-password-alist', or prompted for. A prefix argument of - will -cause the password to be prompted for even if previously memoized." - (interactive - (list (read-file-name "rfa-open: " rfa-node-directory rfa-default-node t) - (read-string "user-name: " (user-login-name)))) - (let ((node - (and (or rfa-password-per-node-p - (not (equal user (user-login-name)))) - node))) - (if (not password) - (setq password - (let ((password - (cdr (assoc user (cdr (assoc node rfa-password-alist)))))) - (or (and (not current-prefix-arg) password) - (rfa-password-read - (format "password for user %s%s: " - user - (if node (format " on node \"%s\"" node) "")) - password)))))) - (let ((result - (sysnetunam (expand-file-name node rfa-node-directory) - (concat user ":" password)))) - (if (interactive-p) - (if result - (message "Opened network connection to %s as %s" node user) - (error "Unable to open network connection"))) - (if (and rfa-password-memoize-p result) - (rfa-set-password password node user)) - result)) - -(defun rfa-close (node) - "Close a network connection to a server using remote file access. -NODE is the network node for the remote machine." - (interactive - (list (read-file-name "rfa-close: " rfa-node-directory rfa-default-node t))) - (let ((result (sysnetunam (expand-file-name node rfa-node-directory) ""))) - (cond ((not (interactive-p)) result) - ((not result) (error "Unable to close network connection")) - (t (message "Closed network connection to %s" node))))) - -(defun rfa-password-read (prompt default) - (let ((rfa-password-accumulator (or default ""))) - (read-from-minibuffer prompt - (and default - (let ((copy (concat default)) - (index 0) - (length (length default))) - (while (< index length) - (aset copy index ?.) - (setq index (1+ index))) - copy)) - rfa-password-map) - rfa-password-accumulator)) - -(defvar rfa-password-map nil) -(if (not rfa-password-map) - (let ((char ? )) - (setq rfa-password-map (make-keymap)) - (while (< char 127) - (define-key rfa-password-map (char-to-string char) - 'rfa-password-self-insert) - (setq char (1+ char))) - (define-key rfa-password-map "\C-g" - 'abort-recursive-edit) - (define-key rfa-password-map "\177" - 'rfa-password-rubout) - (define-key rfa-password-map "\n" - 'exit-minibuffer) - (define-key rfa-password-map "\r" - 'exit-minibuffer))) - -(defvar rfa-password-accumulator nil) - -(defun rfa-password-self-insert () - (interactive) - (setq rfa-password-accumulator - (concat rfa-password-accumulator - (char-to-string last-command-char))) - (insert ?.)) - -(defun rfa-password-rubout () - (interactive) - (delete-char -1) - (setq rfa-password-accumulator - (substring rfa-password-accumulator 0 -1))) - -;;; netunam.el ends here
--- a/lisp/=nnspool.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,409 +0,0 @@ -;;; nnspool.el --- spool access using NNTP for GNU Emacs - -;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Keywords: news - -;; 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. - -;;; Code: - -(require 'nntp) - -(defvar nnspool-inews-program news-inews-program - "*Program to post news.") - -(defvar nnspool-inews-switches '("-h") - "*Switches for nnspool-request-post to pass to `inews' for posting news.") - -(defvar nnspool-spool-directory news-path - "*Local news spool directory.") - -(defvar nnspool-active-file "/usr/lib/news/active" - "*Local news active file.") - -(defvar nnspool-newsgroups-file "/usr/lib/news/newsgroups" - "*Local news newsgroups file.") - -(defvar nnspool-distributions-file "/usr/lib/news/distributions" - "*Local news distributions file.") - -(defvar nnspool-history-file "/usr/lib/news/history" - "*Local news history file.") - - - -(defconst nnspool-version "NNSPOOL 1.12" - "Version numbers of this version of NNSPOOL.") - -(defvar nnspool-current-directory nil - "Current news group directory.") - -;;; -;;; Replacement of Extended Command for retrieving many headers. -;;; - -(defun nnspool-retrieve-headers (sequence) - "Return list of article headers specified by SEQUENCE of article id. -The format of list is - `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. -If there is no References: field, In-Reply-To: field is used instead. -Reader macros for the vector are defined as `nntp-header-FIELD'. -Writer macros for the vector are defined as `nntp-set-header-FIELD'. -Newsgroup must be selected before calling this." - (save-excursion - (set-buffer nntp-server-buffer) - ;;(erase-buffer) - (let ((file nil) - (number (length sequence)) - (count 0) - (headers nil) ;Result list. - (article 0) - (subject nil) - (message-id nil) - (from nil) - (xref nil) - (lines 0) - (date nil) - (references nil)) - (while sequence - ;;(nntp-send-strings-to-server "HEAD" (car sequence)) - (setq article (car sequence)) - (setq file - (concat nnspool-current-directory (prin1-to-string article))) - (if (and (file-exists-p file) - (not (file-directory-p file))) - (progn - (erase-buffer) - (insert-file-contents file) - ;; Make message body invisible. - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (narrow-to-region (point-min) (point)) - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - ;; Make it possible to search for `\nFIELD'. - (goto-char (point-min)) - (insert "\n") - ;; Extract From: - (goto-char (point-min)) - (if (search-forward "\nFrom: " nil t) - (setq from (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq from "(Unknown User)")) - ;; Extract Subject: - (goto-char (point-min)) - (if (search-forward "\nSubject: " nil t) - (setq subject (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq subject "(None)")) - ;; Extract Message-ID: - (goto-char (point-min)) - (if (search-forward "\nMessage-ID: " nil t) - (setq message-id (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq message-id nil)) - ;; Extract Date: - (goto-char (point-min)) - (if (search-forward "\nDate: " nil t) - (setq date (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq date nil)) - ;; Extract Lines: - (goto-char (point-min)) - (if (search-forward "\nLines: " nil t) - (setq lines (string-to-int - (buffer-substring - (point) - (save-excursion (end-of-line) (point))))) - (setq lines 0)) - ;; Extract Xref: - (goto-char (point-min)) - (if (search-forward "\nXref: " nil t) - (setq xref (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq xref nil)) - ;; Extract References: - ;; If no References: field, use In-Reply-To: field instead. - (goto-char (point-min)) - (if (or (search-forward "\nReferences: " nil t) - (search-forward "\nIn-Reply-To: " nil t)) - (setq references (buffer-substring - (point) - (save-excursion (end-of-line) (point)))) - (setq references nil)) - ;; Collect valid article only. - (and article - message-id - (setq headers - (cons (vector article subject from - xref lines date - message-id references) headers))) - )) - (setq sequence (cdr sequence)) - (setq count (1+ count)) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% count 20)) - (message "NNSPOOL: Receiving headers... %d%%" - (/ (* count 100) number))) - ) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (message "NNSPOOL: Receiving headers... done")) - (nreverse headers) - ))) - - -;;; -;;; Replacement of NNTP Raw Interface. -;;; - -(defun nnspool-open-server (host &optional service) - "Open news server on HOST. -If HOST is nil, use value of environment variable `NNTPSERVER'. -If optional argument SERVICE is non-nil, open by the service name." - (let ((host (or host (getenv "NNTPSERVER"))) - (status nil)) - (setq nntp-status-string "") - (cond ((and (file-directory-p nnspool-spool-directory) - (file-exists-p nnspool-active-file) - (string-equal host (system-name))) - (setq status (nnspool-open-server-internal host service))) - ((string-equal host (system-name)) - (setq nntp-status-string - (format "%s has no news spool. Goodbye." host))) - ((null host) - (setq nntp-status-string "NNTP server is not specified.")) - (t - (setq nntp-status-string - (format "NNSPOOL: cannot talk to %s." host))) - ) - status - )) - -(defun nnspool-close-server () - "Close news server." - (nnspool-close-server-internal)) - -(fset 'nnspool-request-quit (symbol-function 'nnspool-close-server)) - -(defun nnspool-server-opened () - "Return server process status, T or NIL. -If the stream is opened, return T, otherwise return NIL." - (and nntp-server-buffer - (get-buffer nntp-server-buffer))) - -(defun nnspool-status-message () - "Return server status response as string." - nntp-status-string - ) - -(defun nnspool-request-article (id) - "Select article by message ID (or number)." - (let ((file (if (stringp id) - (nnspool-find-article-by-message-id id) - (concat nnspool-current-directory (prin1-to-string id))))) - (if (and (stringp file) - (file-exists-p file) - (not (file-directory-p file))) - (save-excursion - (nnspool-find-file file))) - )) - -(defun nnspool-request-body (id) - "Select article body by message ID (or number)." - (if (nnspool-request-article id) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (delete-region (point-min) (point))) - t - ) - )) - -(defun nnspool-request-head (id) - "Select article head by message ID (or number)." - (if (nnspool-request-article id) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (delete-region (1- (point)) (point-max))) - t - ) - )) - -(defun nnspool-request-stat (id) - "Select article by message ID (or number)." - (setq nntp-status-string "NNSPOOL: STAT is not implemented.") - nil - ) - -(defun nnspool-request-group (group) - "Select news GROUP." - (let ((pathname (nnspool-article-pathname - (nnspool-replace-chars-in-string group ?. ?/)))) - (if (file-directory-p pathname) - (setq nnspool-current-directory pathname)) - )) - -(defun nnspool-request-list () - "List active newsgoups." - (save-excursion - (nnspool-find-file nnspool-active-file))) - -(defun nnspool-request-list-newsgroups () - "List newsgroups (defined in NNTP2)." - (save-excursion - (nnspool-find-file nnspool-newsgroups-file))) - -(defun nnspool-request-list-distributions () - "List distributions (defined in NNTP2)." - (save-excursion - (nnspool-find-file nnspool-distributions-file))) - -(defun nnspool-request-last () - "Set current article pointer to the previous article -in the current news group." - (setq nntp-status-string "NNSPOOL: LAST is not implemented.") - nil - ) - -(defun nnspool-request-next () - "Advance current article pointer." - (setq nntp-status-string "NNSPOOL: NEXT is not implemented.") - nil - ) - -(defun nnspool-request-post () - "Post a new news in current buffer." - (save-excursion - ;; We have to work in the server buffer because of NEmacs hack. - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - (set-buffer nntp-server-buffer) - (apply (function call-process-region) - (point-min) (point-max) - nnspool-inews-program 'delete t nil nnspool-inews-switches) - (prog1 - (or (zerop (buffer-size)) - ;; If inews returns strings, it must be error message - ;; unless SPOOLNEWS is defined. - ;; This condition is very weak, but there is no good rule - ;; identifying errors when SPOOLNEWS is defined. - ;; Suggested by ohm@kaba.junet. - (string-match "spooled" (buffer-string))) - ;; Make status message by unfolding lines. - (subst-char-in-region (point-min) (point-max) ?\n ?\\ 'noundo) - (setq nntp-status-string (buffer-string)) - (erase-buffer)) - )) - - -;;; -;;; Replacement of Low-Level Interface to NNTP Server. -;;; - -(defun nnspool-open-server-internal (host &optional service) - "Open connection to news server on HOST by SERVICE (default is nntp)." - (save-excursion - (if (not (string-equal host (system-name))) - (error "NNSPOOL: cannot talk to %s." host)) - ;; Initialize communication buffer. - (setq nntp-server-buffer (get-buffer-create " *nntpd*")) - (set-buffer nntp-server-buffer) - (buffer-flush-undo (current-buffer)) - (erase-buffer) - (kill-all-local-variables) - (setq case-fold-search t) ;Should ignore case. - (setq nntp-server-process nil) - (setq nntp-server-name host) - ;; It is possible to change kanji-fileio-code in this hook. - (run-hooks 'nntp-server-hook) - t - )) - -(defun nnspool-close-server-internal () - "Close connection to news server." - (if (get-file-buffer nnspool-history-file) - (kill-buffer (get-file-buffer nnspool-history-file))) - (if nntp-server-buffer - (kill-buffer nntp-server-buffer)) - (setq nntp-server-buffer nil) - (setq nntp-server-process nil)) - -(defun nnspool-find-article-by-message-id (id) - "Return full pathname of an article identified by message-ID." - (save-excursion - (let ((buffer (get-file-buffer nnspool-history-file))) - (if buffer - (set-buffer buffer) - ;; Finding history file may take lots of time. - (message "Reading history file...") - (set-buffer (find-file-noselect nnspool-history-file)) - (message "Reading history file... done"))) - ;; Search from end of the file. I think this is much faster than - ;; do from the beginning of the file. - (goto-char (point-max)) - (if (re-search-backward - (concat "^" (regexp-quote id) - "[ \t].*[ \t]\\([^ \t/]+\\)/\\([0-9]+\\)[ \t]*$") nil t) - (let ((group (buffer-substring (match-beginning 1) (match-end 1))) - (number (buffer-substring (match-beginning 2) (match-end 2)))) - (concat (nnspool-article-pathname - (nnspool-replace-chars-in-string group ?. ?/)) - number)) - ))) - -(defun nnspool-find-file (file) - "Insert FILE in server buffer safely." - (set-buffer nntp-server-buffer) - (erase-buffer) - (condition-case () - (progn (insert-file-contents file) t) - (file-error nil) - )) - -(defun nnspool-article-pathname (group) - "Make pathname for GROUP." - (concat (file-name-as-directory nnspool-spool-directory) group "/")) - -(defun nnspool-replace-chars-in-string (string from to) - "Replace characters in STRING from FROM to TO." - (let ((string (substring string 0)) ;Copy string. - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (if (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string - )) - -(provide 'nnspool) - -;;; nnspool.el ends here
--- a/lisp/=nntp.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,698 +0,0 @@ -;;; nntp.el --- NNTP (RFC977) Interface for GNU Emacs - -;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Keywords: news - -;; 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: - -;; This implementation is tested on both 1.2a and 1.5 version of the -;; NNTP package. - -;; Troubleshooting of NNTP -;; -;; (1) Select routine may signal an error or fall into infinite loop -;; while waiting for the server response. In this case, you'd better -;; not use byte-compiled codes but original source. If you still have -;; a problems with it, set the variable `nntp-buggy-select' to t. -;; -;; (2) Emacs may hang up while retrieving headers since too many -;; requests have been sent to the NNTP server without reading their -;; replies. In this case, reduce the number of the requests sent to -;; the server at one time by setting the variable -;; `nntp-maximum-request' to a lower value. -;; -;; (3) If the TCP/IP stream (open-network-stream) is not supported by -;; emacs, compile and install `tcp.el' and `tcp.c' which is an -;; emulation program of the stream. If you modified `tcp.c' for your -;; system, please send me the diffs. I'll include some of them in the -;; future releases. - -;;; Code: - -(defvar nntp-server-hook nil - "*Hooks for the NNTP server. -If the kanji code of the NNTP server is different from the local kanji -code, the correct kanji code of the buffer associated with the NNTP -server must be specified as follows: - -\(setq nntp-server-hook - (function - (lambda () - ;; Server's Kanji code is EUC (NEmacs hack). - (make-local-variable 'kanji-fileio-code) - (setq kanji-fileio-code 0)))) - -If you'd like to change something depending on the server in this -hook, use the variable `nntp-server-name'.") - -(defvar nntp-large-newsgroup 50 - "*The number of the articles which indicates a large newsgroup. -If the number of the articles is greater than the value, verbose -messages will be shown to indicate the current status.") - - -(defvar nntp-buggy-select (memq system-type '(fujitsu-uts)) - "*Non-nil if your select routine is buggy. -If the select routine signals error or fall into infinite loop while -waiting for the server response, the variable must be set to t. In -case of Fujitsu UTS, it is set to t since `accept-process-output' -doesn't work properly.") - -(defvar nntp-maximum-request 400 - "*The maximum number of the requests sent to the NNTP server at one time. -If Emacs hangs up while retrieving headers, set the variable to a -lower value.") - -(defvar nntp-debug-read 10000 - "*Display '...' every 10Kbytes of a message being received if it is non-nil. -If it is a number, dots are displayed per the number.") - - -(defconst nntp-version "NNTP 3.12" - "Version numbers of this version of NNTP.") - -(defvar nntp-server-name nil - "The name of the host running NNTP server.") - -(defvar nntp-server-buffer nil - "Buffer associated with NNTP server process.") - -(defvar nntp-server-process nil - "The NNTP server process. -You'd better not use this variable in NNTP front-end program but -instead use `nntp-server-buffer'.") - -(defvar nntp-status-string nil - "Save the server response message. -You'd better not use this variable in NNTP front-end program but -instead call function `nntp-status-message' to get status message.") - -;;; -;;; Extended Command for retrieving many headers. -;;; -;; Retrieving lots of headers by sending command asynchronously. -;; Access functions to headers are defined as macro. - -(defmacro nntp-header-number (header) - "Return article number in HEADER." - (` (aref (, header) 0))) - -(defmacro nntp-set-header-number (header number) - "Set article number of HEADER to NUMBER." - (` (aset (, header) 0 (, number)))) - -(defmacro nntp-header-subject (header) - "Return subject string in HEADER." - (` (aref (, header) 1))) - -(defmacro nntp-set-header-subject (header subject) - "Set article subject of HEADER to SUBJECT." - (` (aset (, header) 1 (, subject)))) - -(defmacro nntp-header-from (header) - "Return author string in HEADER." - (` (aref (, header) 2))) - -(defmacro nntp-set-header-from (header from) - "Set article author of HEADER to FROM." - (` (aset (, header) 2 (, from)))) - -(defmacro nntp-header-xref (header) - "Return xref string in HEADER." - (` (aref (, header) 3))) - -(defmacro nntp-set-header-xref (header xref) - "Set article xref of HEADER to xref." - (` (aset (, header) 3 (, xref)))) - -(defmacro nntp-header-lines (header) - "Return lines in HEADER." - (` (aref (, header) 4))) - -(defmacro nntp-set-header-lines (header lines) - "Set article lines of HEADER to LINES." - (` (aset (, header) 4 (, lines)))) - -(defmacro nntp-header-date (header) - "Return date in HEADER." - (` (aref (, header) 5))) - -(defmacro nntp-set-header-date (header date) - "Set article date of HEADER to DATE." - (` (aset (, header) 5 (, date)))) - -(defmacro nntp-header-id (header) - "Return Id in HEADER." - (` (aref (, header) 6))) - -(defmacro nntp-set-header-id (header id) - "Set article Id of HEADER to ID." - (` (aset (, header) 6 (, id)))) - -(defmacro nntp-header-references (header) - "Return references (or in-reply-to) in HEADER." - (` (aref (, header) 7))) - -(defmacro nntp-set-header-references (header ref) - "Set article references of HEADER to REF." - (` (aset (, header) 7 (, ref)))) - -(defun nntp-retrieve-headers (sequence) - "Return list of article headers specified by SEQUENCE of article id. -The format of list is - `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. -If there is no References: field, In-Reply-To: field is used instead. -Reader macros for the vector are defined as `nntp-header-FIELD'. -Writer macros for the vector are defined as `nntp-set-header-FIELD'. -Newsgroup must be selected before calling this." - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((number (length sequence)) - (last-point (point-min)) - (received 0) - (count 0) - (headers nil) ;Result list. - (article 0) - (subject nil) - (message-id) - (from nil) - (xref nil) - (lines 0) - (date nil) - (references nil)) - ;; Send HEAD command. - (while sequence - (nntp-send-strings-to-server "HEAD" (car sequence)) - (setq sequence (cdr sequence)) - (setq count (1+ count)) - ;; Every 400 header requests we have to read stream in order - ;; to avoid deadlock. - (if (or (null sequence) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (progn - (accept-process-output) - (while (progn - (goto-char last-point) - ;; Count replies. - (while (re-search-forward "^[0-9]" nil t) - (setq received (1+ received))) - (setq last-point (point)) - (< received count)) - ;; If number of headers is greater than 100, give - ;; informative messages. - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% received 20)) - (message "NNTP: Receiving headers... %d%%" - (/ (* received 100) number))) - (nntp-accept-response)) - )) - ) - ;; Wait for text of last command. - (goto-char (point-max)) - (re-search-backward "^[0-9]" nil t) - (if (looking-at "^[23]") - (while (progn - (goto-char (- (point-max) 3)) - (not (looking-at "^\\.\r$"))) - (nntp-accept-response))) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (message "NNTP: Receiving headers... done")) - ;; Now all of replies are received. - (setq received number) - ;; First, fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - ;;(delete-non-matching-lines - ;; "^Subject:\\|^Xref:\\|^From:\\|^Lines:\\|^Date:\\|^References:\\|^[23]") - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (message "NNTP: Parsing headers...")) - ;; Then examines replies. - (goto-char (point-min)) - (while (not (eobp)) - (cond ((looking-at "^[23][0-9][0-9][ \t]+\\([0-9]+\\)[ \t]+\\(<[^>]+>\\)") - (setq article - (string-to-int - (buffer-substring (match-beginning 1) (match-end 1)))) - (setq message-id - (buffer-substring (match-beginning 2) (match-end 2))) - (forward-line 1) - ;; Set default value. - (setq subject nil) - (setq xref nil) - (setq from nil) - (setq lines 0) - (setq date nil) - (setq references nil) - ;; Thanks go to mly@AI.MIT.EDU (Richard Mlynarik) - (while (and (not (eobp)) - (not (memq (following-char) '(?2 ?3)))) - (if (looking-at "\\(From\\|Subject\\|Date\\|Lines\\|Xref\\|References\\|In-Reply-To\\):[ \t]+\\([^ \t\n]+.*\\)\r$") - (let ((s (buffer-substring - (match-beginning 2) (match-end 2))) - (c (char-after (match-beginning 0)))) - ;; We don't have to worry about letter case. - (cond ((char-equal c ?F) ;From: - (setq from s)) - ((char-equal c ?S) ;Subject: - (setq subject s)) - ((char-equal c ?D) ;Date: - (setq date s)) - ((char-equal c ?L) ;Lines: - (setq lines (string-to-int s))) - ((char-equal c ?X) ;Xref: - (setq xref s)) - ((char-equal c ?R) ;References: - (setq references s)) - ;; In-Reply-To: should be used only when - ;; there is no References: field. - ((and (char-equal c ?I) ;In-Reply-To: - (null references)) - (setq references s)) - ))) - (forward-line 1)) - ;; Finished to parse one header. - (if (null subject) - (setq subject "(None)")) - (if (null from) - (setq from "(Unknown User)")) - ;; Collect valid article only. - (and article - message-id - (setq headers - (cons (vector article subject from - xref lines date - message-id references) headers))) - ) - (t (forward-line 1)) - ) - (setq received (1- received)) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% received 20)) - (message "NNTP: Parsing headers... %d%%" - (/ (* received 100) number))) - ) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (message "NNTP: Parsing headers... done")) - (nreverse headers) - ))) - - -;;; -;;; Raw Interface to Network News Transfer Protocol (RFC977). -;;; - -(defun nntp-open-server (host &optional service) - "Open news server on HOST. -If HOST is nil, use value of environment variable `NNTPSERVER'. -If optional argument SERVICE is non-nil, open by the service name." - (let ((host (or host (getenv "NNTPSERVER"))) - (status nil)) - (setq nntp-status-string "") - (cond ((and host (nntp-open-server-internal host service)) - (setq status (nntp-wait-for-response "^[23].*\r$")) - ;; Do check unexpected close of connection. - ;; Suggested by feldmark@hanako.stars.flab.fujitsu.junet. - (if status - (progn (set-process-sentinel nntp-server-process - 'nntp-default-sentinel) - (nntp-send-command "^[25].*\r$" "MODE" "READER")) - ;; We have to close connection here, since function - ;; `nntp-server-opened' may return incorrect status. - (nntp-close-server-internal) - )) - ((null host) - (setq nntp-status-string "NNTP server is not specified.")) - ) - status - )) - -(defun nntp-close-server () - "Close news server." - (unwind-protect - (progn - ;; Un-set default sentinel function before closing connection. - (and nntp-server-process - (eq 'nntp-default-sentinel - (process-sentinel nntp-server-process)) - (set-process-sentinel nntp-server-process nil)) - ;; We cannot send QUIT command unless the process is running. - (if (nntp-server-opened) - (nntp-send-command nil "QUIT")) - ) - (nntp-close-server-internal) - )) - -(fset 'nntp-request-quit (symbol-function 'nntp-close-server)) - -(defun nntp-server-opened () - "Return server process status, T or NIL. -If the stream is opened, return T, otherwise return NIL." - (and nntp-server-process - (memq (process-status nntp-server-process) '(open run)))) - -(defun nntp-status-message () - "Return server status response as string." - (if (and nntp-status-string - ;; NNN MESSAGE - (string-match "[0-9][0-9][0-9][ \t]+\\([^\r]*\\).*$" - nntp-status-string)) - (substring nntp-status-string (match-beginning 1) (match-end 1)) - ;; Empty message if nothing. - "" - )) - -(defun nntp-request-article (id) - "Select article by message ID (or number)." - (if (numberp id) - (setq id (number-to-string id))) - (prog1 - ;; If NEmacs, end of message may look like: "\256\215" (".^M") - (nntp-send-command "^\\.\r$" "ARTICLE" id) - (nntp-decode-text) - )) - -(defun nntp-request-body (id) - "Select article body by message ID (or number)." - (prog1 - ;; If NEmacs, end of message may look like: "\256\215" (".^M") - (nntp-send-command "^\\.\r$" "BODY" id) - (nntp-decode-text) - )) - -(defun nntp-request-head (id) - "Select article head by message ID (or number)." - (prog1 - (nntp-send-command "^\\.\r$" "HEAD" id) - (nntp-decode-text) - )) - -(defun nntp-request-stat (id) - "Select article by message ID (or number)." - (nntp-send-command "^[23].*\r$" "STAT" id)) - -(defun nntp-request-group (group) - "Select news GROUP." - ;; 1.2a NNTP's group command is buggy. "^M" (\r) is not appended to - ;; end of the status message. - (nntp-send-command "^[23].*$" "GROUP" group)) - -(defun nntp-request-list () - "List active newsgroups." - (prog1 - (nntp-send-command "^\\.\r$" "LIST") - (nntp-decode-text) - )) - -(defun nntp-request-list-newsgroups () - "List newsgroups (defined in NNTP2)." - (prog1 - (nntp-send-command "^\\.\r$" "LIST NEWSGROUPS") - (nntp-decode-text) - )) - -(defun nntp-request-list-distributions () - "List distributions (defined in NNTP2)." - (prog1 - (nntp-send-command "^\\.\r$" "LIST DISTRIBUTIONS") - (nntp-decode-text) - )) - -(defun nntp-request-last () - "Set current article pointer to the previous article -in the current news group." - (nntp-send-command "^[23].*\r$" "LAST")) - -(defun nntp-request-next () - "Advance current article pointer." - (nntp-send-command "^[23].*\r$" "NEXT")) - -(defun nntp-request-post () - "Post a new news in current buffer." - (if (nntp-send-command "^[23].*\r$" "POST") - (progn - (nntp-encode-text) - (nntp-send-region-to-server (point-min) (point-max)) - ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not - ;; appended to end of the status message. - (nntp-wait-for-response "^[23].*$") - ))) - -(defun nntp-default-sentinel (proc status) - "Default sentinel function for NNTP server process." - (if (and nntp-server-process - (not (nntp-server-opened))) - (error "NNTP: Connection closed.") - )) - -;; Encoding and decoding of NNTP text. - -(defun nntp-decode-text () - "Decode text transmitted by NNTP. -0. Delete status line. -1. Delete `^M' at end of line. -2. Delete `.' at end of buffer (end of text mark). -3. Delete `.' at beginning of line." - (save-excursion - (set-buffer nntp-server-buffer) - ;; Insert newline at end of buffer. - (goto-char (point-max)) - (if (not (bolp)) - (insert "\n")) - ;; Delete status line. - (goto-char (point-min)) - (delete-region (point) (progn (forward-line 1) (point))) - ;; Delete `^M' at end of line. - ;; (replace-regexp "\r$" "") - (while (not (eobp)) - (end-of-line) - (if (= (preceding-char) ?\r) - (delete-char -1)) - (forward-line 1) - ) - ;; Delete `.' at end of buffer (end of text mark). - (goto-char (point-max)) - (forward-line -1) ;(beginning-of-line) - (if (looking-at "^\\.$") - (delete-region (point) (progn (forward-line 1) (point)))) - ;; Replace `..' at beginning of line with `.'. - (goto-char (point-min)) - ;; (replace-regexp "^\\.\\." ".") - (while (search-forward "\n.." nil t) - (delete-char -1)) - )) - -(defun nntp-encode-text () - "Encode text in current buffer for NNTP transmission. -1. Insert `.' at beginning of line. -2. Insert `.' at end of buffer (end of text mark)." - (save-excursion - ;; Insert newline at end of buffer. - (goto-char (point-max)) - (if (not (bolp)) - (insert "\n")) - ;; Replace `.' at beginning of line with `..'. - (goto-char (point-min)) - ;; (replace-regexp "^\\." "..") - (while (search-forward "\n." nil t) - (insert ".")) - ;; Insert `.' at end of buffer (end of text mark). - (goto-char (point-max)) - (insert ".\r\n") - )) - - -;;; -;;; Synchronous Communication with NNTP Server. -;;; - -(defun nntp-send-command (response cmd &rest args) - "Wait for server RESPONSE after sending CMD and optional ARGS to server." - (save-excursion - ;; Clear communication buffer. - (set-buffer nntp-server-buffer) - (erase-buffer) - (apply 'nntp-send-strings-to-server cmd args) - (if response - (nntp-wait-for-response response) - t) - )) - -(defun nntp-wait-for-response (regexp) - "Wait for server response which matches REGEXP." - (save-excursion - (let ((status t) - (wait t) - (dotnum 0) ;Number of "." being displayed. - (dotsize ;How often "." displayed. - (if (numberp nntp-debug-read) nntp-debug-read 10000))) - (set-buffer nntp-server-buffer) - ;; Wait for status response (RFC977). - ;; 1xx - Informative message. - ;; 2xx - Command ok. - ;; 3xx - Command ok so far, send the rest of it. - ;; 4xx - Command was correct, but couldn't be performed for some - ;; reason. - ;; 5xx - Command unimplemented, or incorrect, or a serious - ;; program error occurred. - (nntp-accept-response) - (while wait - (goto-char (point-min)) - (cond ((looking-at "[23]") - (setq wait nil)) - ((looking-at "[45]") - (setq status nil) - (setq wait nil)) - (t (nntp-accept-response)) - )) - ;; Save status message. - (end-of-line) - (setq nntp-status-string - (buffer-substring (point-min) (point))) - (if status - (progn - (setq wait t) - (while wait - (goto-char (point-max)) - (forward-line -1) ;(beginning-of-line) - ;;(message (buffer-substring - ;; (point) - ;; (save-excursion (end-of-line) (point)))) - (if (looking-at regexp) - (setq wait nil) - (if nntp-debug-read - (let ((newnum (/ (buffer-size) dotsize))) - (if (not (= dotnum newnum)) - (progn - (setq dotnum newnum) - (message "NNTP: Reading %s" - (make-string dotnum ?.)))))) - (nntp-accept-response) - ;;(if nntp-debug-read (message "")) - )) - ;; Remove "...". - (if (and nntp-debug-read (> dotnum 0)) - (message "")) - ;; Successfully received server response. - t - )) - ))) - - -;;; -;;; Low-Level Interface to NNTP Server. -;;; - -(defun nntp-send-strings-to-server (&rest strings) - "Send list of STRINGS to news server as command and its arguments." - (let ((cmd (car strings)) - (strings (cdr strings))) - ;; Command and each argument must be separated by one or more spaces. - (while strings - (setq cmd (concat cmd " " (car strings))) - (setq strings (cdr strings))) - ;; Command line must be terminated by a CR-LF. - (process-send-string nntp-server-process (concat cmd "\r\n")) - )) - -(defun nntp-send-region-to-server (begin end) - "Send current buffer region (from BEGIN to END) to news server." - (save-excursion - ;; We have to work in the buffer associated with NNTP server - ;; process because of NEmacs hack. - (copy-to-buffer nntp-server-buffer begin end) - (set-buffer nntp-server-buffer) - (process-send-region nntp-server-process (point-min) (point-max)) - ;; We cannot erase buffer, because reply may be received. - (delete-region begin end) - )) - -(defun nntp-open-server-internal (host &optional service) - "Open connection to news server on HOST by SERVICE (default is nntp)." - (save-excursion - ;; Use TCP/IP stream emulation package if needed. - (or (fboundp 'open-network-stream) - (require 'tcp)) - ;; Initialize communication buffer. - (setq nntp-server-buffer (get-buffer-create " *nntpd*")) - (set-buffer nntp-server-buffer) - (buffer-flush-undo (current-buffer)) - (erase-buffer) - (kill-all-local-variables) - (setq case-fold-search t) ;Should ignore case. - (setq nntp-server-process - (open-network-stream "nntpd" (current-buffer) - host (or service "nntp"))) - (setq nntp-server-name host) - ;; It is possible to change kanji-fileio-code in this hook. - (run-hooks 'nntp-server-hook) - ;; Return the server process. - nntp-server-process - )) - -(defun nntp-close-server-internal () - "Close connection to news server." - (if nntp-server-process - (delete-process nntp-server-process)) - (if nntp-server-buffer - (kill-buffer nntp-server-buffer)) - (setq nntp-server-buffer nil) - (setq nntp-server-process nil)) - -(defun nntp-accept-response () - "Read response of server. -It is well-known that the communication speed will be much improved by -defining this function as macro." - ;; To deal with server process exiting before - ;; accept-process-output is called. - ;; Suggested by Jason Venner <jason@violet.berkeley.edu>. - ;; This is a copy of `nntp-default-sentinel'. - (or (memq (process-status nntp-server-process) '(open run)) - (error "NNTP: Connection closed.")) - (if nntp-buggy-select - (progn - ;; We cannot use `accept-process-output'. - ;; Fujitsu UTS requires messages during sleep-for. I don't know why. - (message "NNTP: Reading...") - (sleep-for 1) - (message "")) - (condition-case errorcode - (accept-process-output nntp-server-process) - (error - (cond ((string-equal "select error: Invalid argument" (nth 1 errorcode)) - ;; Ignore select error. - nil - ) - (t - (signal (car errorcode) (cdr errorcode)))) - )) - )) - -(provide 'nntp) - -;;; nntp.el ends here
--- a/lisp/=old-shell.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,399 +0,0 @@ -;;; old-shell.el --- run a shell in an Emacs window - -;; Copyright (C) 1985, 1986, 1987, 1990 Free Software Foundation, Inc. - -;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Hacked from tea.el and shell.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 - -;;; Since this mode is built on top of the general command-interpreter-in- -;;; a-buffer mode (comint mode), it shares a common base functionality, -;;; and a common set of bindings, with all modes derived from comint mode. - -;;; For documentation on the functionality provided by comint mode, and -;;; the hooks available for customising it, see the file comint.el. - -;;; Needs fixin: -;;; When sending text from a source file to a subprocess, the process-mark can -;;; move off the window, so you can lose sight of the process interactions. -;;; Maybe I should ensure the process mark is in the window when I send -;;; text to the process? Switch selectable? - -;;; Code: - -(require 'comint) -(defvar shell-popd-regexp "popd" - "*Regexp to match subshell commands equivalent to popd.") - -(defvar shell-pushd-regexp "pushd" - "*Regexp to match subshell commands equivalent to pushd.") - -(defvar shell-cd-regexp "cd" - "*Regexp to match subshell commands equivalent to cd.") - -(defvar explicit-shell-file-name nil - "*If non-nil, is file name to use for explicitly requested inferior shell.") - -(defvar explicit-csh-args - (if (eq system-type 'hpux) - ;; -T persuades HP's csh not to think it is smarter - ;; than us about what terminal modes to use. - '("-i" "-T") - '("-i")) - "*Args passed to inferior shell by M-x shell, if the shell is csh. -Value is a list of strings, which may be nil.") - -(defvar shell-dirstack nil - "List of directories saved by pushd in this buffer's shell.") - -(defvar shell-dirstack-query "dirs" - "Command used by shell-resync-dirlist to query shell.") - -(defvar shell-mode-map ()) -(cond ((not shell-mode-map) - (setq shell-mode-map (copy-keymap comint-mode-map)) - (define-key shell-mode-map "\t" 'comint-dynamic-complete) - (define-key shell-mode-map "\M-?" 'comint-dynamic-list-completions))) - -(defvar shell-mode-hook '() - "*Hook for customising shell mode") - - -;;; Basic Procedures -;;; =========================================================================== -;;; - -(defun shell-mode () - "Major mode for interacting with an inferior shell. -Return after the end of the process' output sends the text from the - end of process to the end of the current line. -Return before end of process output copies rest of line to end (skipping - the prompt) and sends it. -M-x send-invisible reads a line of text without echoing it, and sends it to - the shell. - -If you accidentally suspend your process, use \\[comint-continue-subjob] -to continue it. - -cd, pushd and popd commands given to the shell are watched by Emacs to keep -this buffer's default directory the same as the shell's working directory. -M-x dirs queries the shell and resyncs Emacs' idea of what the current - directory stack is. -M-x dirtrack-toggle turns directory tracking on and off. - -\\{shell-mode-map} -Customisation: Entry to this mode runs the hooks on comint-mode-hook and -shell-mode-hook (in that order). - -Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp are used -to match their respective commands." - (interactive) - (comint-mode) - (setq major-mode 'shell-mode - mode-name "Shell" - comint-prompt-regexp shell-prompt-pattern - comint-input-sentinel 'shell-directory-tracker) - (use-local-map shell-mode-map) - (make-local-variable 'shell-dirstack) - (set (make-local-variable 'shell-dirtrackp) t) - (run-hooks 'shell-mode-hook)) - - -(defun shell () - "Run an inferior shell, with I/O through buffer *shell*. -If buffer exists but shell process is not running, make new shell. -If buffer exists and shell process is running, just switch to buffer *shell*. - -The shell to use comes from the first non-nil variable found from these: -explicit-shell-file-name in Emacs, ESHELL in the environment or SHELL in the -environment. If none is found, /bin/sh is used. - -If a file ~/.emacs_SHELLNAME exists, it is given as initial input, simulating -a start-up file for the shell like .profile or .cshrc. Note that this may -lose due to a timing error if the shell discards input when it starts up. - -The buffer is put in shell-mode, giving commands for sending input -and controlling the subjobs of the shell. - -The shell file name, sans directories, is used to make a symbol name -such as `explicit-csh-arguments'. If that symbol is a variable, -its value is used as a list of arguments when invoking the shell. -Otherwise, one argument `-i' is passed to the shell. - -\(Type \\[describe-mode] in the shell buffer for a list of commands.)" - (interactive) - (if (not (comint-check-proc "*shell*")) - (let* ((prog (or explicit-shell-file-name - (getenv "ESHELL") - (getenv "SHELL") - "/bin/sh")) - (name (file-name-nondirectory prog)) - (startfile (concat "~/.emacs_" name)) - (xargs-name (intern-soft (concat "explicit-" name "-args")))) - (set-buffer (apply 'make-comint "shell" prog - (if (file-exists-p startfile) startfile) - (if (and xargs-name (boundp xargs-name)) - (symbol-value xargs-name) - '("-i")))) - (shell-mode))) - (switch-to-buffer "*shell*")) - - -;;; Directory tracking -;;; =========================================================================== -;;; This code provides the shell mode input sentinel -;;; SHELL-DIRECTORY-TRACKER -;;; that tracks cd, pushd, and popd commands issued to the shell, and -;;; changes the current directory of the shell buffer accordingly. -;;; -;;; This is basically a fragile hack, although it's more accurate than -;;; the original version in shell.el. It has the following failings: -;;; 1. It doesn't know about the cdpath shell variable. -;;; 2. It only spots the first command in a command sequence. E.g., it will -;;; miss the cd in "ls; cd foo" -;;; 3. More generally, any complex command (like ";" sequencing) is going to -;;; throw it. Otherwise, you'd have to build an entire shell interpreter in -;;; emacs lisp. Failing that, there's no way to catch shell commands where -;;; cd's are buried inside conditional expressions, aliases, and so forth. -;;; -;;; The whole approach is a crock. Shell aliases mess it up. File sourcing -;;; messes it up. You run other processes under the shell; these each have -;;; separate working directories, and some have commands for manipulating -;;; their w.d.'s (e.g., the lcd command in ftp). Some of these programs have -;;; commands that do *not* effect the current w.d. at all, but look like they -;;; do (e.g., the cd command in ftp). In shells that allow you job -;;; control, you can switch between jobs, all having different w.d.'s. So -;;; simply saying %3 can shift your w.d.. -;;; -;;; The solution is to relax, not stress out about it, and settle for -;;; a hack that works pretty well in typical circumstances. Remember -;;; that a half-assed solution is more in keeping with the spirit of Unix, -;;; anyway. Blech. -;;; -;;; One good hack not implemented here for users of programmable shells -;;; is to program up the shell w.d. manipulation commands to output -;;; a coded command sequence to the tty. Something like -;;; ESC | <cwd> | -;;; where <cwd> is the new current working directory. Then trash the -;;; directory tracking machinery currently used in this package, and -;;; replace it with a process filter that watches for and strips out -;;; these messages. - -;;; REGEXP is a regular expression. STR is a string. START is a fixnum. -;;; Returns T if REGEXP matches STR where the match is anchored to start -;;; at position START in STR. Sort of like LOOKING-AT for strings. -(defun shell-front-match (regexp str start) - (eq start (string-match regexp str start))) - -(defun shell-directory-tracker (str) - "Tracks cd, pushd and popd commands issued to the shell. -This function is called on each input passed to the shell. -It watches for cd, pushd and popd commands and sets the buffer's -default directory to track these commands. - -You may toggle this tracking on and off with M-x dirtrack-toggle. -If emacs gets confused, you can resync with the shell with M-x dirs. - -See variables shell-cd-regexp, shell-pushd-regexp, and shell-popd-regexp. -Environment variables are expanded, see function substitute-in-file-name." - (condition-case err - (cond (shell-dirtrackp - (string-match "^\\s *" str) ; skip whitespace - (let ((bos (match-end 0)) - (x nil)) - (cond ((setq x (shell-match-cmd-w/optional-arg shell-popd-regexp - str bos)) - (shell-process-popd (substitute-in-file-name x))) - ((setq x (shell-match-cmd-w/optional-arg shell-pushd-regexp - str bos)) - (shell-process-pushd (substitute-in-file-name x))) - ((setq x (shell-match-cmd-w/optional-arg shell-cd-regexp - str bos)) - (shell-process-cd (substitute-in-file-name x))))))) - (error (message (car (cdr err)))))) - - -;;; Try to match regexp CMD to string, anchored at position START. -;;; CMD may be followed by a single argument. If a match, then return -;;; the argument, if there is one, or the empty string if not. If -;;; no match, return nil. - -(defun shell-match-cmd-w/optional-arg (cmd str start) - (and (shell-front-match cmd str start) - (let ((eoc (match-end 0))) ; end of command - (cond ((shell-front-match "\\s *\\(\;\\|$\\)" str eoc) - "") ; no arg - ((shell-front-match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)" - str eoc) - (substring str (match-beginning 1) (match-end 1))) ; arg - (t nil))))) ; something else. -;;; The first regexp is [optional whitespace, (";" or the end of string)]. -;;; The second regexp is [whitespace, (an arg), optional whitespace, -;;; (";" or end of string)]. - - -;;; popd [+n] -(defun shell-process-popd (arg) - (let ((num (if (zerop (length arg)) 0 ; no arg means +0 - (shell-extract-num arg)))) - (if (and num (< num (length shell-dirstack))) - (if (= num 0) ; condition-case because the CD could lose. - (condition-case nil (progn (cd (car shell-dirstack)) - (setq shell-dirstack - (cdr shell-dirstack)) - (shell-dirstack-message)) - (error (message "Couldn't cd."))) - (let* ((ds (cons nil shell-dirstack)) - (cell (nthcdr (- num 1) ds))) - (rplacd cell (cdr (cdr cell))) - (setq shell-dirstack (cdr ds)) - (shell-dirstack-message))) - (message "Bad popd.")))) - - -;;; cd [dir] -(defun shell-process-cd (arg) - (condition-case nil (progn (cd (if (zerop (length arg)) (getenv "HOME") - arg)) - (shell-dirstack-message)) - (error (message "Couldn't cd.")))) - - -;;; pushd [+n | dir] -(defun shell-process-pushd (arg) - (if (zerop (length arg)) - ;; no arg -- swap pwd and car of shell stack - (condition-case nil (if shell-dirstack - (let ((old default-directory)) - (cd (car shell-dirstack)) - (setq shell-dirstack - (cons old (cdr shell-dirstack))) - (shell-dirstack-message)) - (message "Directory stack empty.")) - (message "Couldn't cd.")) - - (let ((num (shell-extract-num arg))) - (if num ; pushd +n - (if (> num (length shell-dirstack)) - (message "Directory stack not that deep.") - (let* ((ds (cons default-directory shell-dirstack)) - (dslen (length ds)) - (front (nthcdr num ds)) - (back (reverse (nthcdr (- dslen num) (reverse ds)))) - (new-ds (append front back))) - (condition-case nil - (progn (cd (car new-ds)) - (setq shell-dirstack (cdr new-ds)) - (shell-dirstack-message)) - (error (message "Couldn't cd."))))) - - ;; pushd <dir> - (let ((old-wd default-directory)) - (condition-case nil - (progn (cd arg) - (setq shell-dirstack - (cons old-wd shell-dirstack)) - (shell-dirstack-message)) - (error (message "Couldn't cd.")))))))) - -;; If STR is of the form +n, for n>0, return n. Otherwise, nil. -(defun shell-extract-num (str) - (and (string-match "^\\+[1-9][0-9]*$" str) - (string-to-int str))) - - -(defun shell-dirtrack-toggle () - "Turn directory tracking on and off in a shell buffer." - (interactive) - (setq shell-dirtrackp (not shell-dirtrackp)) - (message "directory tracking %s." - (if shell-dirtrackp "ON" "OFF"))) - -;;; For your typing convenience: -(fset 'dirtrack-toggle 'shell-dirtrack-toggle) - - -(defun shell-resync-dirs () - "Resync the buffer's idea of the current directory stack. -This command queries the shell with the command bound to -shell-dirstack-query (default \"dirs\"), reads the next -line output and parses it to form the new directory stack. -DON'T issue this command unless the buffer is at a shell prompt. -Also, note that if some other subprocess decides to do output -immediately after the query, its output will be taken as the -new directory stack -- you lose. If this happens, just do the -command again." - (interactive) - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (process-mark proc))) - (goto-char pmark) - (insert shell-dirstack-query) (insert "\n") - (sit-for 0) ; force redisplay - (comint-send-string proc shell-dirstack-query) - (comint-send-string proc "\n") - (set-marker pmark (point)) - (let ((pt (point))) ; wait for 1 line - ;; This extra newline prevents the user's pending input from spoofing us. - (insert "\n") (backward-char 1) - (while (not (looking-at ".+\n")) - (accept-process-output proc) - (goto-char pt))) - (goto-char pmark) (delete-char 1) ; remove the extra newline - ;; That's the dirlist. grab it & parse it. - (let* ((dl (buffer-substring (match-beginning 0) (- (match-end 0) 1))) - (dl-len (length dl)) - (ds '()) ; new dir stack - (i 0)) - (while (< i dl-len) - ;; regexp = optional whitespace, (non-whitespace), optional whitespace - (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir - (setq ds (cons (substring dl (match-beginning 1) (match-end 1)) - ds)) - (setq i (match-end 0))) - (let ((ds (reverse ds))) - (condition-case nil - (progn (cd (car ds)) - (setq shell-dirstack (cdr ds)) - (shell-dirstack-message)) - (error (message "Couldn't cd."))))))) - -;;; For your typing convenience: -(fset 'dirs 'shell-resync-dirs) - - -;;; Show the current dirstack on the message line. -;;; Pretty up dirs a bit by changing "/usr/jqr/foo" to "~/foo". -;;; (This isn't necessary if the dirlisting is generated with a simple "dirs".) -;;; All the commands that mung the buffer's dirstack finish by calling -;;; this guy. -(defun shell-dirstack-message () - (let ((msg "") - (ds (cons default-directory shell-dirstack))) - (while ds - (let ((dir (car ds))) - (if (string-match (format "^%s\\(/\\|$\\)" (getenv "HOME")) dir) - (setq dir (concat "~/" (substring dir (match-end 0))))) - (if (string-equal dir "~/") (setq dir "~")) - (setq msg (concat msg dir " ")) - (setq ds (cdr ds)))) - (message msg))) - -(provide 'shell) - -;;; old-shell.el ends here
--- a/lisp/=sc-alist.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,134 +0,0 @@ -;; -*- Mode: Emacs-Lisp -*- -;; sc-alist.el -- Version 1.0 (used to be baw-alist.el) - -;; association list utilities providing insertion, deletion, sorting -;; fetching off key-value pairs in association lists. - -;; ========== Disclaimer ========== -;; This software is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor accepts -;; responsibility to anyone for the consequences of using it or for -;; whether it serves any particular purpose or works at all, unless he -;; says so in writing. - -;; This software was written as part of the supercite author's -;; official duty as an employee of the United States Government and is -;; thus in the public domain. You are free to use that particular -;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It -;; would be nice, though if when you use any of this code, you give -;; due credit to the author. - -;; ========== Author (unless otherwise stated) ======================== -;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc. -;; TELE: (301) 593-3330 1014 West Street -;; INET: bwarsaw@cen.com Laurel, Md 20707 -;; UUCP: uunet!cen.com!bwarsaw -;; -(provide 'sc-alist) - - -(defun asort (alist-symbol key) - "Move a specified key-value pair to the head of an alist. -The alist is referenced by ALIST-SYMBOL. Key-value pair to move to -head is one matching KEY. Returns the sorted list and doesn't affect -the order of any other key-value pair. Side effect sets alist to new -sorted list." - (set alist-symbol - (sort (copy-alist (eval alist-symbol)) - (function (lambda (a b) (equal (car a) key)))))) - - -(defun aelement (key value) - "Makes a list of a cons cell containing car of KEY and cdr of VALUE. -The returned list is suitable as an element of an alist." - (list (cons key value))) - - -(defun aheadsym (alist) - "Return the key symbol at the head of ALIST." - (car (car alist))) - - -(defun anot-head-p (alist key) - "Find out if a specified key-value pair is not at the head of an alist. -The alist to check is specified by ALIST and the key-value pair is the -one matching the supplied KEY. Returns nil if ALIST is nil, or if -key-value pair is at the head of the alist. Returns t if key-value -pair is not at the head of alist. ALIST is not altered." - (not (equal (aheadsym alist) key))) - - -(defun aput (alist-symbol key &optional value) - "Inserts a key-value pair into an alist. -The alist is referenced by ALIST-SYMBOL. The key-value pair is made -from KEY and optionally, VALUE. Returns the altered alist or nil if -ALIST is nil. - -If the key-value pair referenced by KEY can be found in the alist, and -VALUE is supplied non-nil, then the value of KEY will be set to VALUE. -If VALUE is not supplied, or is nil, the key-value pair will not be -modified, but will be moved to the head of the alist. If the key-value -pair cannot be found in the alist, it will be inserted into the head -of the alist (with value nil if VALUE is nil or not supplied)." - (let ((elem (aelement key value)) - alist) - (asort alist-symbol key) - (setq alist (eval alist-symbol)) - (cond ((null alist) (set alist-symbol elem)) - ((anot-head-p alist key) (set alist-symbol (nconc elem alist))) - (value (setcar alist (car elem))) - (t alist)))) - - -(defun adelete (alist-symbol key) - "Delete a key-value pair from the alist. -Alist is referenced by ALIST-SYMBOL and the key-value pair to remove -is pair matching KEY. Returns the altered alist." - (asort alist-symbol key) - (let ((alist (eval alist-symbol))) - (cond ((null alist) nil) - ((anot-head-p alist key) alist) - (t (set alist-symbol (cdr alist)))))) - - -(defun aget (alist key &optional keynil-p) - "Returns the value in ALIST that is associated with KEY. -Optional KEYNIL-P describes what to do if the value associated with -KEY is nil. If KEYNIL-P is not supplied or is nil, and the value is -nil, then KEY is returned. If KEYNIL-P is non-nil, then nil would be -returned. - -If no key-value pair matching KEY could be found in ALIST, or ALIST is -nil then nil is returned. ALIST is not altered." - (let ((copy (copy-alist alist))) - (cond ((null alist) nil) - ((progn (asort 'copy key) - (anot-head-p copy key)) nil) - ((cdr (car copy))) - (keynil-p nil) - ((car (car copy))) - (t nil)))) - - -(defun amake (alist-symbol keylist &optional valuelist) - "Make an association list. -The association list is attached to the alist referenced by -ALIST-SYMBOL. Each element in the KEYLIST becomes a key and is -associated with the value in VALUELIST with the same index. If -VALUELIST is not supplied or is nil, then each key in KEYLIST is -associated with nil. - -KEYLIST and VALUELIST should have the same number of elements, but -this isn't enforced. If VALUELIST is smaller than KEYLIST, remaining -keys are associated with nil. If VALUELIST is larger than KEYLIST, -extra values are ignored. Returns the created alist." - (let ((keycar (car keylist)) - (keycdr (cdr keylist)) - (valcar (car valuelist)) - (valcdr (cdr valuelist))) - (cond ((null keycdr) - (aput alist-symbol keycar valcar)) - (t - (amake alist-symbol keycdr valcdr) - (aput alist-symbol keycar valcar)))) - (eval alist-symbol))
--- a/lisp/=sc-elec.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,198 +0,0 @@ -;; -*- Mode: Emacs-Lisp -*- -;; sc-elec.el -- Version 2.3 - -;; ========== Introduction ========== -;; This file contains sc-electric mode for viewing reference headers. -;; It is loaded automatically by supercite.el when needed. - -;; ========== Disclaimer ========== -;; This software is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor accepts -;; responsibility to anyone for the consequences of using it or for -;; whether it serves any particular purpose or works at all, unless he -;; says so in writing. - -;; Some of this software was written as part of the supercite author's -;; official duty as an employee of the United States Government and is -;; thus in the public domain. You are free to use that particular -;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It -;; would be nice, though if when you use any of this code, you give -;; due credit to the author. - -;; Other parts of this code were written by other people. Wherever -;; possible, credit to that author, and the copy* notice supplied by -;; the author are included with that code. In all cases, the spirit, -;; if not the letter of the GNU General Public Licence applies. - -;; ========== Author (unless otherwise stated) ========== -;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc. -;; TELE: (301) 593-3330 1014 West Street -;; UUCP: uunet!cen.com!bwarsaw Laurel, MD 20707 -;; INET: bwarsaw@cen.com - -;; Want to be on the Supercite mailing list? -;; -;; Send articles to: -;; INET: supercite@anthem.nlm.nih.gov -;; UUCP: uunet!anthem.nlm.nih.gov!supercite -;; -;; Send administrivia (additions/deletions to list, etc) to: -;; INET: supercite-request@anthem.nlm.nih.gov -;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request -;; -(provide 'sc-elec) - - -;; ====================================================================== -;; set up vars for major mode - -(defconst sc-electric-bufname "*sc-erefs*" - "*Supercite's electric buffer name.") - - -(defvar sc-electric-mode-hook nil - "*Hook for sc-electric-mode.") - - - -;; ====================================================================== -;; sc-electric-mode - -(defun sc-electric-mode (&optional arg) - "Quasi major mode for viewing supercite reference headers. -Commands are: \\{sc-electric-mode-map} -Sc-electric-mode is not intended to be run interactively, but rather -accessed through supercite's electric reference feature. See -sc-insert-reference for more details. Optional ARG is the initial -header style to use, unless not supplied or invalid, in which case -sc-preferred-header-style is used." - (let ((gal sc-gal-information) - (sc-eref-style (if arg ;; assume passed arg is okay - arg - (if (and (natnump sc-preferred-header-style) - (sc-valid-index-p sc-preferred-header-style)) - sc-preferred-header-style - 0)))) - (get-buffer-create sc-electric-bufname) - ;; set up buffer and enter command loop - (save-excursion - (save-window-excursion - (pop-to-buffer sc-electric-bufname) - (kill-all-local-variables) - (setq sc-gal-information gal - buffer-read-only t - mode-name "Supercite-Electric-References" - major-mode 'sc-electric-mode) - (use-local-map sc-electric-mode-map) - (sc-eref-show sc-eref-style) - (run-hooks 'sc-electric-mode-hook) - (recursive-edit) - )) - (if sc-eref-style - (condition-case nil - (eval (nth sc-eref-style sc-rewrite-header-list)) - (error nil) - )) - ;; now restore state - (kill-buffer sc-electric-bufname) - )) - - - -;; ====================================================================== -;; functions for electric mode - -(defun sc-eref-index (index) - "Check INDEX to be sure it is a valid index into sc-rewrite-header-list. -If sc-electric-circular-p is non-nil, then list is considered circular -so that movement across the ends of the list wraparound." - (let ((last (1- (length sc-rewrite-header-list)))) - (cond ((sc-valid-index-p index) index) - ((< index 0) - (if sc-electric-circular-p last - (progn (error "No preceding reference headers in list.") 0))) - ((> index last) - (if sc-electric-circular-p 0 - (progn (error "No following reference headers in list.") last))) - ) - )) - - -(defun sc-eref-show (index) - "Show reference INDEX in sc-rewrite-header-list." - (setq sc-eref-style (sc-eref-index index)) - (save-excursion - (set-buffer sc-electric-bufname) - (let ((ref (nth sc-eref-style sc-rewrite-header-list)) - (buffer-read-only nil)) - (erase-buffer) - (goto-char (point-min)) - (condition-case err - (progn - (set-mark (point-min)) - (eval ref) - (message "Showing reference header %d." sc-eref-style) - (goto-char (point-max)) - ) - (void-function - (progn (message - "Symbol's function definition is void: %s (Header %d)" - (symbol-name (car (cdr err))) - sc-eref-style) - (beep) - )) - )))) - - - -;; ====================================================================== -;; interactive commands - -(defun sc-eref-next () - "Display next reference in other buffer." - (interactive) - (sc-eref-show (1+ sc-eref-style))) - - -(defun sc-eref-prev () - "Display previous reference in other buffer." - (interactive) - (sc-eref-show (1- sc-eref-style))) - - -(defun sc-eref-setn () - "Set reference header selected as preferred." - (interactive) - (setq sc-preferred-header-style sc-eref-style) - (message "Preferred reference style set to header %d." sc-eref-style)) - - -(defun sc-eref-goto (refnum) - "Show reference style indexed by REFNUM. -If REFNUM is an invalid index, don't go to that reference and return -nil." - (interactive "NGoto Reference: ") - (if (sc-valid-index-p refnum) - (sc-eref-show refnum) - (error "Invalid reference: %d. (Range: [%d .. %d])" - refnum 0 (1- (length sc-rewrite-header-list))) - )) - - -(defun sc-eref-jump () - "Set reference header to preferred header." - (interactive) - (sc-eref-show sc-preferred-header-style)) - - -(defun sc-eref-abort () - "Exit from electric reference mode without inserting reference." - (interactive) - (setq sc-eref-style nil) - (exit-recursive-edit)) - - -(defun sc-eref-exit () - "Exit from electric reference mode and insert selected reference." - (interactive) - (exit-recursive-edit))
--- a/lisp/=sc.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1547 +0,0 @@ -;; -*- Mode: Emacs-Lisp -*- -;; sc.el -- Version 2.3 (used to be supercite.el) - -;; ========== Introduction ========== -;; Citation and attribution package for various GNU emacs news and -;; electronic mail reading subsystems. This version of supercite should -;; work with Rmail and GNUS as found in Emacs 19. It may also work with -;; VM 4.40+ and MH-E 3.7. - -;; This package does not do any yanking of messages, but instead -;; massages raw reply buffers set up by the reply/forward functions in -;; the news/mail subsystems. Therefore, such useful operations as -;; yanking and citing portions of the original article (instead of the -;; whole article) are not within the ability or responsibility of -;; supercite. - -;; ========== Disclaimer ========== -;; This software is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor, nor any -;; author's past, present, or future employers accepts responsibility -;; to anyone for the consequences of using it or for whether it serves -;; any particular purpose or works at all, unless he says so in -;; writing. - -;; Some of this software was written as part of the supercite author's -;; official duty as an employee of the United States Government and is -;; thus not subject to copyright. You are free to use that particular -;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It -;; would be nice, though if when you use any of this or other freely -;; available code, you give due credit to the author. - -;; Other parts of this code were written by other people. Wherever -;; possible, credit to that author, and the copy* notice supplied by -;; the author are included with that code. The supercite author is no -;; longer an employee of the U.S. Government so the GNU Public Licence -;; should be considered in effect for all enhancements and bug fixes -;; performed by the author. - -;; ========== Author (unless otherwise stated) ======================== -;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc. -;; TELE: (301) 593-3330 1014 West Street -;; INET: bwarsaw@cen.com Laurel, Md 20707 -;; UUCP: uunet!cen.com!bwarsaw -;; -;; Want to be on the Supercite mailing list? -;; -;; Send articles to: -;; Internet: supercite@anthem.nlm.nih.gov -;; UUCP: uunet!anthem.nlm.nih.gov!supercite -;; -;; Send administrivia (additions/deletions to list, etc) to: -;; Internet: supercite-request@anthem.nlm.nih.gov -;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request - -;; ========== Credits and Thanks ========== -;; This package was derived from the Superyank 1.11 package as posted -;; to the net. Superyank 1.11 was inspired by code and ideas from -;; Martin Neitzel and Ashwin Ram. Supercite version 2.3 has evolved -;; through the comments and suggestions of the supercite mailing list -;; which consists of many authors and users of the various mail and -;; news reading subsystems. - -;; Many folks on the supercite mailing list have contributed their -;; help in debugging, making suggestions and supplying support code or -;; bug fixes for the previous versions of supercite. I want to thank -;; everyone who helped, especially (in no particular order): -;; -;; Mark D. Baushke, Khalid Sattar, David Lawrence, Chris Davis, Kyle -;; Jones, Kayvan Sylvan, Masanobu Umeda, Dan Jacobson, Piet van -;; Oostrum, Hamish (H.I.) Macdonald, and Joe Wells. -;; -;; I don't mean to leave anyone out. All who have helped have been -;; appreciated. - -;; ========== Getting Started ========== -;; Here is a quick guide to getting started with supercite. The -;; information contained here is mostly excerpted from the more -;; detailed explanations given in the accompanying README file. -;; Naturally, there are many customizations you can do to give your -;; replies that personalized flair, but the instructions in this -;; section should be sufficient for getting started. - -;; First, to connect supercite to any mail/news reading subsystem, put -;; this in your .emacs file: -;; -;; (setq mail-yank-hooks 'sc-cite-original) ; for old mail agents -;; (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only -;; (add-hook 'mail-citation-hook 'sc-cite-original) ; for newer mail agents -;; -;; If supercite is not pre-loaded into your emacs session, you should -;; add the following autoload: -;; -;; (autoload 'sc-cite-original "sc" "Supercite 2.3" t) -;; -;; Finally, if you want to customize supercite, you should do it in a -;; function called my-supercite-hook and: -;; -;; (setq sc-load-hook 'my-supercite-hook) - -(require 'assoc) - - -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -;; start of user defined variables -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - -(defvar sc-nested-citation-p nil - "*Controls whether to use nested or non-nested citation style. -Non-nil uses nested citations, nil uses non-nested citations. Type -\\[sc-describe] for more information.") - -(defvar sc-citation-leader " " - "*String comprising first part of a citation.") - -(defvar sc-citation-delimiter ">" - "*String comprising third part of a citation. -This string is used in both nested and non-nested citations.") - -(defvar sc-citation-separator " " - "*String comprising fourth and last part of a citation.") - -(defvar sc-default-author-name "Anonymous" - "*String used when author's name cannot be determined.") - -(defvar sc-default-attribution "Anon" - "*String used when author's attribution cannot be determined.") - -;; Noriya KOBAYASHI (nk@ics.osaka-u.ac.jp) writes to the supercite -;; mailing list: -;; I use supercite in Nemacs-3.3.2. In order to handle citation using -;; Kanji, [...set sc-cite-regexp to...] -;; "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*\\s *>+" -;; -(defvar sc-cite-regexp "\\s *[-a-zA-Z0-9_.]*>+\\s *" - "*Regular expression describing how a already cited line begins. -The regexp is only used at the beginning of a line, so it doesn't need -to start with a '^'.") - -(defvar sc-titlecue-regexp "\\s +-+\\s +" - "*Regular expression describing the separator between names and titles. -Set to nil to treat entire field as a name.") - -(defvar sc-spacify-name-chars '(?_ ?* ?+ ?=) - "*List of characters to convert to spaces if found in an author's name.") - -(defvar sc-nicknames-alist - '(("Michael" "Mike") - ("Daniel" "Dan") - ("David" "Dave") - ("Jonathan" "John") - ("William" "Bill") - ("Elizabeth" "Beth") - ("Elizabeth" "Betsy") - ("Kathleen" "Kathy") - ("Smith" "Smitty")) - "*Association list of names and their common nicknames. -Entries are of the form (NAME NICKNAME), and NAMEs can have more than -one nickname. Nicknames will not be automatically used as an -attribution string, since I'm not sure this is really polite, but if a -name is glommed from the author name and presented in the attribution -string completion list, the matching nicknames will also be presented. -Set this variable to nil to defeat nickname expansions. Also note that -nicknames are not put in the supercite information alist.") - -(defvar sc-confirm-always-p t - "*If non-nil, always confirm attribution string before citing text body.") - -(defvar sc-preferred-attribution 'firstname - "*Specifies which part of the author's name becomes the attribution. -The value of this variable must be one of the following quoted symbols: - - emailname -- email terminus name - initials -- initials of author - firstname -- first name of author - lastname -- last name of author - middlename1 -- first middle name of author - middlename2 -- second middle name of author - ... - -Middle name indexes can be any positive integer greater than 0, though -it is unlikely that many authors will supply more than one middle -name, if that many.") - -(defvar sc-use-only-preference-p nil - "*Controls what happens when the preferred attribution cannot be found. -If non-nil, then sc-default-attribution will be used. If nil, then -some secondary scheme will be employed to find a suitable attribution -string.") - -(defvar sc-downcase-p nil - "*Non-nil means downcase the attribution and citation strings.") - -(defvar sc-rewrite-header-list - '((sc-no-header) - (sc-header-on-said) - (sc-header-inarticle-writes) - (sc-header-regarding-adds) - (sc-header-attributed-writes) - (sc-header-verbose) - (sc-no-blank-line-or-header) - ) - "*List of reference header rewrite functions. -The variable sc-preferred-header-style controls which function in this -list is chosen for automatic reference header insertions. Electric -reference mode will cycle through this list of functions. For more -information, type \\[sc-describe].") - -(defvar sc-preferred-header-style 1 - "*Index into sc-rewrite-header-list specifying preferred header style. -Index zero accesses the first function in the list.") - -(defvar sc-electric-references-p t - "*Use electric references if non-nil.") - -(defvar sc-electric-circular-p t - "*Treat electric references as circular if non-nil.") - -(defvar sc-mail-fields-list - '("date" "message-id" "subject" "newsgroups" "references" - "from" "return-path" "path" "reply-to" "organization" - "reply" ) - "*List of mail header whose values will be saved by supercite. -These values can be used in header rewrite functions by accessing them -with the sc-field function. Mail headers in this list are case -insensitive and do not require a trailing colon.") - -(defvar sc-mumble-string "" - "*Value returned by sc-field if chosen field cannot be found.") - -(defvar sc-nuke-mail-headers-p t - "*Nuke or don't nuke mail headers. -If non-nil, nuke mail headers after gleaning useful information from -them.") - -(defvar sc-reference-tag-string ">>>>> " - "*String used at the beginning of built-in reference headers.") - -(defvar sc-fill-paragraph-hook 'sc-fill-paragraph - "*Hook for filling a paragraph. -This hook gets executed when you fill a paragraph either manually or -automagically. It expects point to be within the extent of the -paragraph that is going to be filled. This hook allows you to use a -different paragraph filling package than the one supplied with -supercite.") - -(defvar sc-auto-fill-region-p nil - "*If non-nil, automatically fill each paragraph after it has been cited.") - -(defvar sc-auto-fill-query-each-paragraph-p nil - "*If non-nil, query before filling each paragraph. -No querying and no filling will be performed if sc-auto-fill-region-p -is set to nil.") - -(defvar sc-fixup-whitespace-p nil - "*If non-nil, delete all leading white space before citing.") - -(defvar sc-all-but-cite-p nil - "*If non-nil, sc-cite-original does everything but cite the text. -This is useful for manually citing large messages, or portions of -large messages. When non-nil, sc-cite-original will still set up all -necessary variables and databases, but will skip the citing routine -which modify the reply buffer's text.") - -(defvar sc-load-hook nil - "*User definable hook. -Runs after supercite is loaded. Set your customizations here.") - -(defvar sc-pre-hook nil - "*User definable hook. -Runs before sc-cite-original executes.") - -(defvar sc-post-hook nil - "*User definable hook. -Runs after sc-cite-original executes.") - -(defvar sc-header-nuke-list - '("via" "origin" "status" "received" "remailed" "cc" "sender" "replied" - "organization" "keywords" "distribution" "xref" "references" "expires" - "approved" "summary" "precedence" "subject" "newsgroup[s]?" - "\\(followup\\|apparently\\|errors\\|\\(\\(in-\\)?reply\\)?-\\)?to" - "x-[a-z0-9-]+" "[a-z-]*message-id" "\\(summary-\\)?line[s]" - "\\(\\(return\\|reply\\)-\\)?path" "\\(posted-\\)?date" - "\\(mail-\\)?from") - "*List of mail headers to remove from body of reply.") - - - -;; ====================================================================== -;; keymaps - -(defvar sc-default-keymap - '(lambda () - (local-set-key "\C-c\C-r" 'sc-insert-reference) - (local-set-key "\C-c\C-t" 'sc-cite) - (local-set-key "\C-c\C-a" 'sc-recite) - (local-set-key "\C-c\C-u" 'sc-uncite) - (local-set-key "\C-c\C-i" 'sc-insert-citation) - (local-set-key "\C-c\C-o" 'sc-open-line) - (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually) - (local-set-key "\C-cq" 'sc-fill-paragraph-manually) - (local-set-key "\C-c\C-m" 'sc-modify-information) - (local-set-key "\C-cf" 'sc-view-field) - (local-set-key "\C-cg" 'sc-glom-headers) - (local-set-key "\C-c\C-v" 'sc-version) - (local-set-key "\C-c?" 'sc-describe) - ) - "*Default keymap if major-mode can't be found in `sc-local-keymaps'.") - -(defvar sc-local-keymaps - '((mail-mode - (lambda () - (local-set-key "\C-c\C-r" 'sc-insert-reference) - (local-set-key "\C-c\C-t" 'sc-cite) - (local-set-key "\C-c\C-a" 'sc-recite) - (local-set-key "\C-c\C-u" 'sc-uncite) - (local-set-key "\C-c\C-i" 'sc-insert-citation) - (local-set-key "\C-c\C-o" 'sc-open-line) - (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually) - (local-set-key "\C-cq" 'sc-fill-paragraph-manually) - (local-set-key "\C-c\C-m" 'sc-modify-information) - (local-set-key "\C-cf" 'sc-view-field) - (local-set-key "\C-cg" 'sc-glom-headers) - (local-set-key "\C-c\C-v" 'sc-version) - (local-set-key "\C-c?" 'sc-describe) - )) - (mh-letter-mode - (lambda () - (local-set-key "\C-c\C-r" 'sc-insert-reference) - (local-set-key "\C-c\C-t" 'sc-cite) - (local-set-key "\C-c\C-a" 'sc-recite) - (local-set-key "\C-c\C-u" 'sc-uncite) - (local-set-key "\C-ci" 'sc-insert-citation) - (local-set-key "\C-c\C-o" 'sc-open-line) - (local-set-key "\C-cq" 'sc-fill-paragraph-manually) - (local-set-key "\C-c\C-m" 'sc-modify-information) - (local-set-key "\C-cf" 'sc-view-field) - (local-set-key "\C-cg" 'sc-glom-headers) - (local-set-key "\C-c\C-v" 'sc-version) - (local-set-key "\C-c?" 'sc-describe) - )) - (news-reply-mode mail-mode) - (vm-mail-mode mail-mode) - (e-reply-mode mail-mode) - (n-reply-mode mail-mode) - ) - "*List of keymaps to use with the associated major-mode.") - -(defvar sc-electric-mode-map nil - "*Keymap for sc-electric-mode.") - -(if sc-electric-mode-map - nil - (setq sc-electric-mode-map (make-sparse-keymap)) - (define-key sc-electric-mode-map "p" 'sc-eref-prev) - (define-key sc-electric-mode-map "n" 'sc-eref-next) - (define-key sc-electric-mode-map "s" 'sc-eref-setn) - (define-key sc-electric-mode-map "j" 'sc-eref-jump) - (define-key sc-electric-mode-map "x" 'sc-eref-abort) - (define-key sc-electric-mode-map "\r" 'sc-eref-exit) - (define-key sc-electric-mode-map "\n" 'sc-eref-exit) - (define-key sc-electric-mode-map "q" 'sc-eref-exit) - (define-key sc-electric-mode-map "g" 'sc-eref-goto) - ) - -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -;; end of user defined variables -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - -;; ====================================================================== -;; global variables, not user accessible - -(defconst sc-version-number "2.3" - "Supercite's version number.") - -;; when rnewspost.el patch is installed (or function is overloaded) -;; this should be nil since supercite now does this itself. -(setq news-reply-header-hook nil) - -;; autoload for sc-electric-mode -(autoload 'sc-electric-mode "sc-elec" - "Quasi-major mode for viewing supercite reference headers." nil) - -;; global alists (gals), misc variables. make new bytecompiler happy -(defvar sc-gal-information nil - "Internal global alist variable containing information.") -(defvar sc-gal-attributions nil - "Internal global alist variable containing attributions.") -(defvar sc-fill-arg nil - "Internal fill argument holder.") -(defvar sc-cite-context nil - "Internal citation context holder.") -(defvar sc-force-confirmation-p nil - "Internal variable.") - -(make-variable-buffer-local 'sc-gal-attributions) -(make-variable-buffer-local 'sc-gal-information) -(make-variable-buffer-local 'sc-leached-keymap) -(make-variable-buffer-local 'sc-fill-arg) -(make-variable-buffer-local 'sc-cite-context) - -(setq-default sc-gal-attributions nil) -(setq-default sc-gal-information nil) -(setq-default sc-leached-keymap (current-local-map)) -(setq-default sc-fill-arg nil) -(setq-default sc-cite-context nil) - - - -;; ====================================================================== -;; miscellaneous support functions - -(defun sc-mark () - "Mark compatibility between emacs v18 and v19." - (let ((zmacs-regions nil)) - (marker-position (mark-marker)))) - -(defun sc-update-gal (attribution) - "Update the information alist. -Add ATTRIBUTION and compose the nested and non-nested citation -strings." - (let ((attrib (if sc-downcase-p (downcase attribution) attribution))) - (aput 'sc-gal-information "sc-attribution" attrib) - (aput 'sc-gal-information "sc-nested-citation" - (concat attrib sc-citation-delimiter)) - (aput 'sc-gal-information "sc-citation" - (concat sc-citation-leader - attrib - sc-citation-delimiter - sc-citation-separator)))) - -(defun sc-valid-index-p (index) - "Returns t if INDEX is a valid index into sc-rewrite-header-list." - (let ((last (1- (length sc-rewrite-header-list)))) - (and (natnump index) ;; a number, and greater than or equal to zero - (<= index last) ;; less than or equal to the last index - ))) - -(defun sc-string-car (namestring) - "Return the string-equivalent \"car\" of NAMESTRING. - - example: (sc-string-car \"John Xavier Doe\") - => \"John\"" - (substring namestring - (progn (string-match "\\s *" namestring) (match-end 0)) - (progn (string-match "\\s *\\S +" namestring) (match-end 0)))) - -(defun sc-string-cdr (namestring) - "Return the string-equivalent \"cdr\" of NAMESTRING. - - example: (sc-string-cdr \"John Xavier Doe\") - => \"Xavier Doe\"" - (substring namestring - (progn (string-match "\\s *\\S +\\s *" namestring) - (match-end 0)))) - -(defun sc-linepos (&optional position col-p) - "Return the character position at various line positions. -Optional POSITION can be one of the following symbols: - bol == beginning of line - boi == beginning of indentation - eol == end of line [default] - -Optional COL-P non-nil returns current-column instead of character position." - (let ((tpnt (point)) - rval) - (cond - ((eq position 'bol) (beginning-of-line)) - ((eq position 'boi) (back-to-indentation)) - (t (end-of-line))) - (setq rval (if col-p (current-column) (point))) - (goto-char tpnt) - rval)) - - -;; ====================================================================== -;; this section snarfs mail fields and places them in the info alist - -(defun sc-build-header-zap-regexp () - "Return a regexp for sc-mail-yank-clear-headers." - (let ((headers sc-header-nuke-list) - (regexp nil)) - (while headers - (setq regexp (concat regexp - "^" (car headers) ":" - (if (cdr headers) "\\|" nil))) - (setq headers (cdr headers))) - regexp)) - -(defun sc-mail-yank-clear-headers (start end) - "Nuke mail headers between START and END." - (if (and sc-nuke-mail-headers-p sc-header-nuke-list) - (let ((regexp (sc-build-header-zap-regexp))) - (save-excursion - (goto-char start) - (if (search-forward "\n\n" end t) - (save-restriction - (narrow-to-region start (point)) - (goto-char start) - (while (let ((case-fold-search t)) - (re-search-forward regexp nil t)) - (beginning-of-line) - (delete-region (point) - (progn (re-search-forward "\n[^ \t]") - (forward-char -1) - (point))) - ))) - )))) - -(defun sc-mail-fetch-field (field) - "Return the value of the header field FIELD. -The buffer is expected to be narrowed to just the headers of the -message." - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) - (name (concat "^" (regexp-quote field) "[ \t]*:[ \t]*"))) - (goto-char (point-min)) - (if (re-search-forward name nil t) - (let ((opoint (point))) - (while (progn (forward-line 1) - (looking-at "[ \t]"))) - (buffer-substring opoint (1- (point)))))))) - -(defun sc-fetch-fields (start end) - "Fetch the mail fields in the region from START to END. -These fields can be accessed in header rewrite functions with sc-field." - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (let ((fields sc-mail-fields-list)) - (while fields - (let ((value (sc-mail-fetch-field (car fields))) - (next (cdr fields))) - (and value - (aput 'sc-gal-information (car fields) value)) - (setq fields next))) - (if (sc-mail-fetch-field "from") - (aput 'sc-gal-information "from" (sc-mail-fetch-field "from"))))))) - -(defun sc-field (field) - "Return the alist information associated with the FIELD. -If FIELD is not a valid key, return sc-mumble-string." - (or (aget sc-gal-information field) sc-mumble-string)) - - -;; ====================================================================== -;; built-in reference header rewrite functions - -(defun sc-no-header () - "Does nothing. Use this instead of nil to get a blank header." - ()) - -(defun sc-no-blank-line-or-header() - "Similar to sc-no-header except it removes the preceding blank line." - (if (not (bobp)) - (if (and (eolp) - (progn (forward-line -1) - (or (looking-at mail-header-separator) - (and (eq major-mode 'mh-letter-mode) - (mh-in-header-p))))) - (progn (forward-line) - (let ((kill-lines-magic t)) (kill-line)))))) - -(defun sc-header-on-said () - "\"On <date>, <from> said:\", unless 1. the \"from\" field cannot be -found, in which case nothing is inserted; or 2. the \"date\" field is -missing in which case only the from part is printed." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (when (sc-field "date"))) - (if (not (string= whofrom "")) - (insert sc-reference-tag-string - (if (not (string= when "")) - (concat "On " when ", ") "") - whofrom " said:\n")))) - -(defun sc-header-inarticle-writes () - "\"In article <message-id>, <from> writes:\" -Treats \"message-id\" and \"from\" fields similar to sc-header-on-said." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (msgid (sc-field "message-id"))) - (if (not (string= whofrom "")) - (insert sc-reference-tag-string - (if (not (string= msgid "")) - (concat "In article " msgid ", ") "") - whofrom " writes:\n")))) - -(defun sc-header-regarding-adds () - "\"Regarding <subject>; <from> adds:\" -Treats \"subject\" and \"from\" fields similar to sc-header-on-said." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (subj (sc-field "subject"))) - (if (not (string= whofrom "")) - (insert sc-reference-tag-string - (if (not (string= subj "")) - (concat "Regarding " subj "; ") "") - whofrom " adds:\n")))) - -(defun sc-header-attributed-writes () - "\"<sc-attribution>\" == <sc-author> <address> writes: -Treats these fields in a similar manner to sc-header-on-said." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (reply (sc-field "sc-reply-address")) - (from (sc-field "sc-from-address")) - (attr (sc-field "sc-attribution")) - (auth (sc-field "sc-author"))) - (if (not (string= whofrom "")) - (insert sc-reference-tag-string - (if (not (string= attr "")) - (concat "\"" attr "\" == " ) "") - (if (not (string= auth "")) - (concat auth " ") "") - (if (not (string= reply "")) - (concat "<" reply ">") - (if (not (string= from "")) - (concat "<" from ">") "")) - " writes:\n")))) - -(defun sc-header-verbose () - "Very verbose, some say gross." - (let* ((sc-mumble-string "") - (whofrom (sc-field "from")) - (reply (sc-field "sc-reply-address")) - (from (sc-field "sc-from-address")) - (author (sc-field "sc-author")) - (date (sc-field "date")) - (org (sc-field "organization")) - (msgid (sc-field "message-id")) - (ngrps (sc-field "newsgroups")) - (subj (sc-field "subject")) - (refs (sc-field "references")) - (cite (sc-field "sc-citation")) - (nl sc-reference-tag-string)) - (if (not (string= whofrom "")) - (insert (if (not (string= date "")) - (concat nl "On " date ",\n") "") - (concat nl (if (not (string= author "")) - author - whofrom) "\n") - (if (not (string= org "")) - (concat nl "from the organization of " org "\n") "") - (if (not (string= reply "")) - (concat nl "who can be reached at: " reply "\n") - (if (not (string= from "")) - (concat nl "who can be reached at: " from "\n") "")) - (if (not (string= cite "")) - (concat nl "(whose comments are cited below with \"" - cite "\"),\n") "") - (if (not (string= msgid "")) - (concat nl "had this to say in article " msgid "\n") "") - (if (not (string= ngrps "")) - (concat nl "in newsgroups " ngrps "\n") "") - (if (not (string= subj "")) - (concat nl "concerning the subject of " subj "\n") "") - (if (not (string= refs "")) - (concat nl "(see " refs " for more details)\n") "") - )))) - - -;; ====================================================================== -;; this section queries the user for necessary information - -(defun sc-query (&optional default) - "Query for an attribution string with the optional DEFAULT choice. -Returns the string entered by the user, if non-empty and non-nil, or -DEFAULT otherwise. If DEFAULT is not supplied, sc-default-attribution -is used." - (if (not default) (setq default sc-default-attribution)) - (let* ((prompt (concat "Enter attribution string: (default " default ") ")) - (query (read-string prompt))) - (if (or (null query) - (string= query "")) - default - query))) - -(defun sc-confirm () - "Confirm the preferred attribution with the user." - (if (or sc-confirm-always-p - sc-force-confirmation-p) - (aput 'sc-gal-attributions - (let* ((default (aheadsym sc-gal-attributions)) - chosen - (prompt (concat "Complete " - (cond - ((eq sc-cite-context 'citing) "cite") - ((eq sc-cite-context 'reciting) "recite") - (t "")) - " attribution string: (default " - default ") ")) - (minibuffer-local-completion-map - (copy-keymap minibuffer-local-completion-map))) - (define-key minibuffer-local-completion-map "\C-g" - '(lambda () (interactive) (beep) (throw 'select-abort nil))) - (setq chosen (completing-read prompt sc-gal-attributions)) - (if (or (not chosen) - (string= chosen "")) - default - chosen))))) - - -;; ====================================================================== -;; this section contains primitive functions used in the email address -;; parsing schemes. they extract name fields from various parts of -;; the "from:" field. - -(defun sc-style1-addresses (from-string &optional delim) - "Extract the author's email terminus from email address FROM-STRING. -Match addresses of the style \"name%[stuff].\" when called with DELIM -of \"%\" and addresses of the style \"[stuff]name@[stuff]\" when -called with DELIM \"@\". If DELIM is nil or not provided, matches -addresses of the style \"name\"." - (and (string-match (concat "[a-zA-Z0-9_-]+" delim) from-string 0) - (substring from-string - (match-beginning 0) - (- (match-end 0) (if (null delim) 0 1))))) - -(defun sc-style2-addresses (from-string) - "Extract the author's email terminus from email address FROM-STRING. -Match addresses of the style \"[stuff]![stuff]...!name[stuff].\"" - (let ((eos (length from-string)) - (mstart (string-match "![a-zA-Z0-9_-]+\\([^!a-zA-Z0-9_-]\\|$\\)" - from-string 0)) - (mend (match-end 0))) - (and mstart - (substring from-string (1+ mstart) (- mend (if (= mend eos) 0 1))) - ))) - -(defun sc-get-address (from-string author) - "Get the full email address path from FROM-STRING. -AUTHOR is the author's name (which is removed from the address)." - (let ((eos (length from-string))) - (if (string-match (concat "\\(^\\|^\"\\)" author - "\\(\\s +\\|\"\\s +\\)") from-string 0) - (let ((addr (substring from-string (match-end 0) eos))) - (if (and (= (aref addr 0) ?<) - (= (aref addr (1- (length addr))) ?>)) - (substring addr 1 (1- (length addr))) - addr)) - (if (string-match "[a-zA-Z0-9!@%._-]+" from-string 0) - (substring from-string (match-beginning 0) (match-end 0)) - "") - ))) - -(defun sc-get-emailname (from-string) - "Get the email terminus name from FROM-STRING." - (cond - ((sc-style1-addresses from-string "%")) - ((sc-style1-addresses from-string "@")) - ((sc-style2-addresses from-string)) - ((sc-style1-addresses from-string nil)) - (t (substring from-string 0 10)))) - - -;; ====================================================================== -;; this section contains functions that will extract a list of names -;; from the name field string. - -(defun sc-spacify-name-chars (name) - (let ((len (length name)) - (s 0)) - (while (< s len) - (if (memq (aref name s) sc-spacify-name-chars) - (aset name s 32)) - (setq s (1+ s))) - name)) - -(defun sc-name-substring (string start end extend) - "Extract the specified substring of STRING from START to END. -EXTEND is the number of characters on each side to extend the -substring." - (and start - (let ((sos (+ start extend)) - (eos (- end extend))) - (substring string sos - (or (string-match sc-titlecue-regexp string sos) eos) - )))) - -(defun sc-extract-namestring (from-string) - "Extract the name string from FROM-STRING. -This should be the author's full name minus an optional title." - (let ((pstart (string-match "(.*)" from-string 0)) - (pend (match-end 0)) - (qstart (string-match "\".*\"" from-string 0)) - (qend (match-end 0)) - (bstart (string-match "\\([.a-zA-Z0-9_-]+\\s *\\)+" from-string 0)) - (bend (match-end 0))) - (sc-spacify-name-chars - (cond - ((sc-name-substring from-string pstart pend 1)) - ((sc-name-substring from-string qstart qend 1)) - ((sc-name-substring from-string bstart bend 0)) - )))) - -(defun sc-chop-namestring (namestring) - "Convert NAMESTRING to a list of names. - - example: (sc-namestring-to-list \"John Xavier Doe\") - => (\"John\" \"Xavier\" \"Doe\")" - (if (not (string= namestring "")) - (append (list (sc-string-car namestring)) - (sc-chop-namestring (sc-string-cdr namestring))))) - -(defun sc-strip-initials (namelist) - "Extract the author's initials from the NAMELIST." - (if (not namelist) - nil - (concat (if (string= (car namelist) "") - "" - (substring (car namelist) 0 1)) - (sc-strip-initials (cdr namelist))))) - - -;; ====================================================================== -;; this section handles selection of the attribution and citation strings - -(defun sc-populate-alists (from-string) - "Put important and useful information in the alists using FROM-STRING. -Return the list of name symbols." - (let* ((namelist (sc-chop-namestring (sc-extract-namestring from-string))) - (revnames (reverse (cdr namelist))) - (midnames (reverse (cdr revnames))) - (firstname (car namelist)) - (midnames (reverse (cdr revnames))) - (lastname (car revnames)) - (initials (sc-strip-initials namelist)) - (emailname (sc-get-emailname from-string)) - (n 1) - (symlist (list 'emailname 'initials 'firstname 'lastname))) - - ;; put basic information - (aput 'sc-gal-attributions 'firstname firstname) - (aput 'sc-gal-attributions 'lastname lastname) - (aput 'sc-gal-attributions 'emailname emailname) - (aput 'sc-gal-attributions 'initials initials) - - (aput 'sc-gal-information "sc-firstname" firstname) - (aput 'sc-gal-information "sc-lastname" lastname) - (aput 'sc-gal-information "sc-emailname" emailname) - (aput 'sc-gal-information "sc-initials" initials) - - ;; put middle names and build sc-author entry - (let ((author (concat firstname " "))) - (while midnames - (let ((name (car midnames)) - (next (cdr midnames)) - (symbol (intern (format "middlename%d" n))) - (string (format "sc-middlename-%d" n))) - ;; first put new middlename - (aput 'sc-gal-attributions symbol name) - (aput 'sc-gal-information string name) - (setq n (1+ n)) - (nconc symlist (list symbol)) - - ;; now build author name - (setq author (concat author name " ")) - - ;; incr loop - (setq midnames next) - )) - (setq author (concat author lastname)) - - ;; put author name and email address - (aput 'sc-gal-information "sc-author" author) - (aput 'sc-gal-information "sc-from-address" - (sc-get-address from-string author)) - (aput 'sc-gal-information "sc-reply-address" - (sc-get-address (sc-field "reply-to") author)) - ) - ;; return value - symlist)) - -(defun sc-sort-attribution-alist () - "Put preferred attribution at head of attributions alist." - (asort 'sc-gal-attributions sc-preferred-attribution) - - ;; use backup scheme if preference is not legal - (if (or (null sc-preferred-attribution) - (anot-head-p sc-gal-attributions sc-preferred-attribution) - (let ((prefval (aget sc-gal-attributions - sc-preferred-attribution))) - (or (null prefval) - (string= prefval "")))) - ;; no legal attribution - (if sc-use-only-preference-p - (aput 'sc-gal-attributions 'sc-user-query - (sc-query sc-default-attribution)) - ;; else use secondary scheme - (asort 'sc-gal-attributions 'firstname)))) - -(defun sc-build-attribution-alist (from-string) - "Extract attributions from FROM-STRING, applying preferences." - (let ((symlist (sc-populate-alists from-string)) - (headval (progn (sc-sort-attribution-alist) - (aget sc-gal-attributions - (aheadsym sc-gal-attributions) t)))) - - ;; for each element in the symlist, remove the corresponding - ;; key-value pair in the alist, then insert just the value. - (while symlist - (let ((value (aget sc-gal-attributions (car symlist) t)) - (next (cdr symlist))) - (if (not (or (null value) - (string= value ""))) - (aput 'sc-gal-attributions value)) - (adelete 'sc-gal-attributions (car symlist)) - (setq symlist next))) - - ;; add nicknames to the completion list - (let ((gal sc-gal-attributions)) - (while gal - (let ((nns sc-nicknames-alist) - (galname (car (car gal)))) - (while nns - (if (string= galname (car (car nns))) - (aput 'sc-gal-attributions (car (cdr (car nns))))) - (setq nns (cdr nns))) - (setq gal (cdr gal))))) - - ;; now reinsert the head (preferred) attribution unless it is nil, - ;; this effectively just moves the head value to the front of the - ;; list. - (if headval - (aput 'sc-gal-attributions headval)) - - ;; check to be sure alist is not nil - (if (null sc-gal-attributions) - (aput 'sc-gal-attributions sc-default-attribution)))) - -(defun sc-select () - "Select an attribution and create a citation string." - (cond - (sc-nested-citation-p - (sc-update-gal "")) - ((null (aget sc-gal-information "from" t)) - (aput 'sc-gal-information "sc-author" sc-default-author-name) - (sc-update-gal (sc-query sc-default-attribution))) - ((null sc-gal-attributions) - (sc-build-attribution-alist (aget sc-gal-information "from" t)) - (sc-confirm) - (sc-update-gal (aheadsym sc-gal-attributions))) - (t - (sc-confirm) - (sc-update-gal (aheadsym sc-gal-attributions)))) - t) - - -;; ====================================================================== -;; region citing and unciting - -(defun sc-cite-region (start end) - "Cite a region delineated by START and END." - (save-excursion - ;; set real end-of-region - (goto-char end) - (forward-line 1) - (set-mark (point)) - ;; goto real beginning-of-region - (goto-char start) - (beginning-of-line) - (let ((fstart (point)) - (fend (point))) - (while (< (point) (sc-mark)) - ;; remove leading whitespace if desired - (and sc-fixup-whitespace-p - (fixup-whitespace)) - ;; if end of line then perhaps autofill - (cond ((eolp) - (or (= fstart fend) - (not sc-auto-fill-region-p) - (and sc-auto-fill-query-each-paragraph-p - (not (y-or-n-p "Fill this paragraph? "))) - (save-excursion (set-mark fend) - (goto-char (/ (+ fstart fend 1) 2)) - (run-hooks 'sc-fill-paragraph-hook))) - (setq fstart (point) - fend (point))) - ;; not end of line so perhaps cite it - ((not (looking-at sc-cite-regexp)) - (insert (aget sc-gal-information "sc-citation"))) - (sc-nested-citation-p - (insert (aget sc-gal-information "sc-nested-citation")))) - (setq fend (point)) - (forward-line 1)) - (and sc-auto-fill-query-each-paragraph-p - (message " ")) - ))) - -(defun sc-uncite-region (start end cite-regexp) - "Uncite a previously cited region delineated by START and END. -CITE-REGEXP describes how a cited line of texts starts. Unciting also -auto-fills paragraph if sc-auto-fill-region-p is non-nil." - (save-excursion - (set-mark end) - (goto-char start) - (beginning-of-line) - (let ((fstart (point)) - (fend (point))) - (while (< (point) (sc-mark)) - ;; if end of line, then perhaps autofill - (cond ((eolp) - (or (= fstart fend) - (not sc-auto-fill-region-p) - (and sc-auto-fill-query-each-paragraph-p - (not (y-or-n-p "Fill this paragraph? "))) - (save-excursion (set-mark fend) - (goto-char (/ (+ fstart fend 1) 2)) - (run-hooks 'sc-fill-paragraph-hook))) - (setq fstart (point) - fend (point))) - ;; not end of line so perhaps uncite it - ((looking-at cite-regexp) - (save-excursion - (save-restriction - (narrow-to-region (sc-linepos 'bol) (sc-linepos)) - (beginning-of-line) - (delete-region (point-min) - (progn (re-search-forward cite-regexp - (point-max) - t) - (match-end 0))))))) - (setq fend (point)) - (forward-line 1))))) - - -;; ====================================================================== -;; this section contains paragraph filling support - -(defun sc-guess-fill-prefix (&optional literalp) - "Guess the fill prefix used on the current line. -Use various heuristics to find the fill prefix. Search begins on first -non-blank line after point. - - 1) If fill-prefix is already bound to the empty string, return - nil. - - 2) If fill-prefix is already bound, but not to the empty - string, return the value of fill-prefix. - - 3) If the current line starts with the last chosen citation - string, then that string is returned. - - 4) If the current line starts with a string matching the regular - expression sc-cite-regexp, return the match. Note that if - optional LITERALP is provided and non-nil, then the *string* - that matches the regexp is return. Otherwise, if LITERALP is - not provided or is nil, the *regexp* sc-cite-regexp is - returned. - - 5) If the current line starts with any number of characters, - followed by the sc-citation-delimiter and then white space, - that match is returned. See comment #4 above for handling of - LITERALP. - - 6) Nil is returned." - (save-excursion - ;; scan for first non-blank line in the region - (beginning-of-line) - (skip-chars-forward "\n\t ") - (beginning-of-line) - (let ((citation (aget sc-gal-information "sc-citation")) - (generic-citation - (concat "\\s *[^ \t\n" sc-citation-delimiter "]+>\\s +"))) - (cond - ((string= fill-prefix "") nil) ;; heuristic #1 - (fill-prefix) ;; heuristic #2 - ((looking-at (regexp-quote citation)) citation) ;; heuristic #3 - ((looking-at sc-cite-regexp) ;; heuristic #4 - (if literalp - (buffer-substring - (point) - (progn (re-search-forward (concat sc-cite-regexp "\\s *") - (point-max) nil) - (point))) - sc-cite-regexp)) - ((looking-at generic-citation) ;; heuristic #5 - (if literalp - (buffer-substring - (point) - (progn (re-search-forward generic-citation) (point))) - generic-citation)) - (t nil))))) ;; heuristic #6 - -(defun sc-consistent-cite-p (prefix) - "Check current paragraph for consistent citation. -Scans to paragraph delineated by (forward|backward)-paragraph to see -if all lines start with PREFIX. Returns t if entire paragraph is -consistently cited, nil otherwise." - (save-excursion - (let ((end (progn (forward-paragraph) - (beginning-of-line) - (or (not (eolp)) - (forward-char -1)) - (point))) - (start (progn (backward-paragraph) - (beginning-of-line) - (or (not (eolp)) - (forward-char 1)) - (point))) - (badline t)) - (goto-char start) - (beginning-of-line) - (while (and (< (point) end) - badline) - (setq badline (looking-at prefix)) - (forward-line 1)) - badline))) - -(defun sc-fill-start (fill-prefix) - "Find buffer position of start of region which begins with FILL-PREFIX. -Restrict scan to current paragraph." - (save-excursion - (let ((badline nil) - (top (save-excursion - (backward-paragraph) - (beginning-of-line) - (or (not (eolp)) - (forward-char 1)) - (point)))) - (while (and (not badline) - (> (point) top)) - (forward-line -1) - (setq badline (not (looking-at fill-prefix))))) - (forward-line 1) - (point))) - -(defun sc-fill-end (fill-prefix) - "Find the buffer position of end of region which begins with FILL-PREFIX. -Restrict scan to current paragraph." - (save-excursion - (let ((badline nil) - (bot (save-excursion - (forward-paragraph) - (beginning-of-line) - (or (not (eolp)) - (forward-char -1)) - (point)))) - (while (and (not badline) - (< (point) bot)) - (beginning-of-line) - (setq badline (not (looking-at fill-prefix))) - (forward-line 1))) - (forward-line -1) - (point))) - -(defun sc-fill-paragraph () - "Supercite's paragraph fill function. -Fill the paragraph containing or following point. Use -sc-guess-fill-prefix to find the fill-prefix for the paragraph. - -If the paragraph is inconsistently cited (mixed fill-prefix), then the -user is queried to restrict the the fill to only those lines around -point which begin with the fill prefix. - -The variable sc-fill-arg is passed to fill-paragraph and -fill-region-as-paragraph which controls justification of the -paragraph. sc-fill-arg is set by sc-fill-paragraph-manually." - (save-excursion - (let ((pnt (point)) - (fill-prefix (sc-guess-fill-prefix t))) - (cond - ((not fill-prefix) - (fill-paragraph sc-fill-arg)) - ((sc-consistent-cite-p fill-prefix) - (fill-paragraph sc-fill-arg)) - ((y-or-n-p "Inconsistent citation found. Restrict? ") - (message "") - (fill-region-as-paragraph (progn (goto-char pnt) - (sc-fill-start fill-prefix)) - (progn (goto-char pnt) - (sc-fill-end fill-prefix)) - sc-fill-arg)) - (t - (message "") - (progn - (setq fill-prefix (aget sc-gal-information "sc-citation")) - (fill-paragraph sc-fill-arg))))))) - - -;; ====================================================================== -;; the following functions are the top level, interactive commands that -;; can be bound to key strokes - -(defun sc-insert-reference (arg) - "Insert, at point, a reference header in the body of the reply. -Numeric ARG indicates which header style from sc-rewrite-header-list -to use when rewriting the header. No supplied ARG indicates use of -sc-preferred-header-style. - -With just \\[universal-argument], electric reference insert mode is -entered, regardless of the value of sc-electric-references-p. See -sc-electric-mode for more information." - (interactive "P") - (if (consp arg) - (sc-electric-mode) - (let ((pref (cond ((sc-valid-index-p arg) arg) - ((sc-valid-index-p sc-preferred-header-style) - sc-preferred-header-style) - (t 0)))) - (if sc-electric-references-p (sc-electric-mode pref) - (condition-case err - (eval (nth pref sc-rewrite-header-list)) - (void-function - (progn (message - "Symbol's function definition is void: %s. (Header %d)." - (symbol-name (car (cdr err))) - pref) - (beep))) - (error - (progn (message "Error evaluating rewrite header function %d." - pref) - (beep))) - ))))) - -(defun sc-cite (arg) - "Cite the region of text between point and mark. -Numeric ARG, if supplied, is passed unaltered to sc-insert-reference." - (interactive "P") - (if (not (sc-mark)) - (error "Please designate a region to cite (i.e. set the mark).")) - (catch 'select-abort - (let ((sc-cite-context 'citing) - (sc-force-confirmation-p (interactive-p))) - (sc-select) - (undo-boundary) - (let ((xchange (if (> (sc-mark) (point)) nil - (exchange-point-and-mark) - t))) - (sc-insert-reference arg) - (sc-cite-region (point) (sc-mark)) - ;; leave point on first cited line - (while (and (< (point) (sc-mark)) - (not (looking-at (aget sc-gal-information - (if sc-nested-citation-p - "sc-nested-citation" - "sc-citation"))))) - (forward-line 1)) - (and xchange - (exchange-point-and-mark)) - )))) - -(defun sc-uncite () - "Uncite the region between point and mark." - (interactive) - (if (not (sc-mark)) - (error "Please designate a region to uncite (i.e. set the mark).")) - (undo-boundary) - (let ((xchange (if (> (sc-mark) (point)) nil - (exchange-point-and-mark) - t)) - (fp (or (sc-guess-fill-prefix) - ""))) - (sc-uncite-region (point) (sc-mark) fp) - (and xchange - (exchange-point-and-mark)))) - -(defun sc-recite () - "Recite the region by first unciting then citing the text." - (interactive) - (if (not (sc-mark)) - (error "Please designate a region to recite (i.e. set the mark).")) - (catch 'select-abort - (let ((sc-cite-context 'reciting) - (sc-force-confirmation-p t)) - (sc-select) - (undo-boundary) - (let ((xchange (if (> (sc-mark) (point)) nil - (exchange-point-and-mark) - t)) - (fp (or (sc-guess-fill-prefix) - ""))) - (sc-uncite-region (point) (sc-mark) fp) - (sc-cite-region (point) (sc-mark)) - (and xchange - (exchange-point-and-mark)) - )))) - -(defun sc-insert-citation () - "Insert citation string at beginning of current line." - (interactive) - (save-excursion - (beginning-of-line) - (insert (aget sc-gal-information "sc-citation")))) - -(defun sc-open-line (arg) - "Insert a newline and leave point before it. -Also inserts the guessed prefix at the beginning of the new line. With -numeric ARG, inserts that many new lines." - (interactive "p") - (save-excursion - (let ((start (point)) - (string (or (sc-guess-fill-prefix t) - ""))) - (open-line arg) - (goto-char start) - (forward-line 1) - (while (< 0 arg) - (insert string) - (forward-line 1) - (setq arg (- arg 1)))))) - -(defun sc-fill-paragraph-manually (arg) - "Fill current cited paragraph. -Really just runs the hook sc-fill-paragraph-hook, however it does set -the global variable sc-fill-arg to the value of ARG. This is -currently the only way to pass an argument to a hookified function." - (interactive "P") - (setq sc-fill-arg arg) - (run-hooks 'sc-fill-paragraph-hook)) - -(defun sc-modify-information (arg) - "Interactively modify information in the information alist. -\\[universal-argument] if supplied, deletes the entry from the alist. -You can add an entry by supplying a key instead of completing." - (interactive "P") - (let* ((delete-p (consp arg)) - (action (if delete-p "delete" "modify")) - (defaultkey (aheadsym sc-gal-information)) - (prompt (concat "Select information key to " - action ": (default " - defaultkey ") ")) - (key (completing-read prompt sc-gal-information)) - ) - (if (or (string= key "") - (null key)) - (setq key defaultkey)) - (if delete-p (adelete 'sc-gal-information key) - (let* ((oldval (aget sc-gal-information key t)) - (prompt (concat "Enter new value for key \"" - key "\" (default \"" oldval "\") ")) - (newval (read-input prompt))) - (if (or (string= newval "") - (null newval)) - nil - (aput 'sc-gal-information key newval) - ))))) - -(defun sc-view-field (arg) - "View field values in the information alist. -This is essentially an interactive version of sc-field, and is similar -to sc-modify-information, except that the field values can't be -modified. With \\[universal-argument], if supplied, inserts the value -into the current buffer as well." - (interactive "P") - (let* ((defaultkey (aheadsym sc-gal-information)) - (prompt (concat "View information key: (default " - defaultkey ") ")) - (key (completing-read prompt sc-gal-information))) - (if (or (string= key "") - (null key)) - (setq key defaultkey)) - (let* ((val (aget sc-gal-information key t)) - (pval (if val (concat "\"" val "\"") "nil"))) - (message "value of key %s: %s" key pval) - (if (and key (consp arg)) (insert val))))) - -(defun sc-glom-headers () - "Glom information from mail headers in region between point and mark. -Any old information is lost, unless an error occurs." - (interactive) - (let ((attr (copy-sequence sc-gal-attributions)) - (info (copy-sequence sc-gal-information))) - (setq sc-gal-attributions nil - sc-gal-information nil) - (let (start end - (sc-force-confirmation-p t) - (sc-cite-context nil)) - (let ((mark-active t)) - (setq start (region-beginning) - end (region-end))) - (sc-fetch-fields start end) - (if (null sc-gal-information) - (progn - (message "No mail headers found! Restoring old information.") - (setq sc-gal-attributions attr - sc-gal-information info)) - (sc-mail-yank-clear-headers start end) - (if (not (catch 'select-abort - (condition-case foo - (sc-select) - (quit (beep) (throw 'select-abort nil))) - )) - (setq sc-gal-attributions attr - sc-gal-information info)) - )))) - -(defun sc-version (arg) - "Show supercite version. -Universal argument (\\[universal-argument]) ARG inserts version -information in the current buffer instead of printing the message in -the echo area." - (interactive "P") - (if (consp arg) - (insert "Using Supercite version " sc-version-number) - (message "Using Supercite version %s" sc-version-number))) - - -;; ====================================================================== -;; leach onto current mode - -(defun sc-append-current-keymap () - "Append some useful key bindings to the current local key map. -This searches sc-local-keymap for the keymap to install based on the -major-mode of the current buffer." - (let ((hook (car (cdr (assq major-mode sc-local-keymaps))))) - (cond - ((not hook) - (run-hooks 'sc-default-keymap)) - ((not (listp hook)) - (setq hook (car (cdr (assq hook sc-local-keymaps)))) - (run-hooks 'hook)) - (t - (run-hooks 'hook)))) - (setq sc-leached-keymap (current-local-map))) - -(defun sc-snag-all-keybindings () - "Snag all keybindings in major-mode's current keymap." - (let* ((curkeymap (current-local-map)) - (symregexp ".*sc-.*\n") - (docstring (substitute-command-keys "\\{curkeymap}")) - (start 0) - (maxend (length docstring)) - (spooge "")) - (while (and (< start maxend) - (string-match symregexp docstring start)) - (setq spooge (concat spooge (substring docstring - (match-beginning 0) - (match-end 0)))) - (setq start (match-end 0))) - spooge)) - -(defun sc-spoogify-docstring () - "Modifies (makes into spooge) the docstring for the current major mode. -This will leach the keybinding descriptions for supercite onto the end -of the current major mode's docstring. If major mode is preloaded, -this function will first make a copy of the list associated with the -mode, then modify this copy." - (let* ((symfunc (symbol-function major-mode)) - (doc-cdr (and (listp symfunc) (nthcdr 2 symfunc))) - (doc-str (documentation major-mode))) - (cond - ;; is a docstring even provided? - ((not (stringp doc-str))) - ;; have we already leached on? - ((string-match "Supercite" doc-str)) - ;; lets build the new doc string - (t - (let* ((described (sc-snag-all-keybindings)) - (commonstr " - -The major mode for this buffer has been modified to include the -Supercite 2.3 package for handling attributions and citations of -original messages in email replies. For more information on this -package, type \"\\[sc-describe]\".") - (newdoc-str - (concat doc-str commonstr - (if (not (string= described "")) - (concat "\n\nThe following keys are bound " - "to Supercite commands:\n\n" - described))) - )) - (cond - (doc-cdr - (condition-case nil - (setcar doc-cdr newdoc-str) - (error - ;; the major mode must be preloaded, make a copy first - (setq symfunc (copy-sequence (symbol-function major-mode)) - doc-cdr (nthcdr 2 symfunc)) - (setcar doc-cdr newdoc-str) - (fset major-mode symfunc)))) - ;; lemacs 19 byte-code. - ;; Set function to a new byte-code vector with the - ;; new documentation in the documentation slot (element 4). - ;; We can't use aset because aset won't allow you to modify - ;; a byte-code vector. - ;; Include element 5 if the vector has one. - (t - (fset major-mode - (apply 'make-byte-code - (aref symfunc 0) (aref symfunc 1) - (aref symfunc 2) (aref symfunc 3) - newdoc-str - (if (> (length symfunc) 5) - (list (aref symfunc 5))))) - ))))))) - - -;; ====================================================================== -;; this section contains default hooks and hook support for execution - -;;;###autoload -(defun sc-cite-original () - "Hook version of sc-cite. -This is callable from the various mail and news readers' reply -function according to the agreed upon standard. See \\[sc-describe] -for more details. Sc-cite-original does not do any yanking of the -original message but it does require a few things: - - 1) The reply buffer is the current buffer. - - 2) The original message has been yanked and inserted into the - reply buffer. - - 3) Verbose mail headers from the original message have been - inserted into the reply buffer directly before the text of the - original message. - - 4) Point is at the beginning of the verbose headers. - - 5) Mark is at the end of the body of text to be cited." - (run-hooks 'sc-pre-hook) - (setq sc-gal-attributions nil) - (setq sc-gal-information nil) - (let (start end) - (let ((mark-active t)) - (setq start (region-beginning) - end (region-end))) - (sc-fetch-fields start end) - (sc-mail-yank-clear-headers start end) - (if (not sc-all-but-cite-p) - (sc-cite sc-preferred-header-style)) - (sc-append-current-keymap) - (sc-spoogify-docstring) - (run-hooks 'sc-post-hook))) - - -;; ====================================================================== -;; describe this package -;; -(defun sc-describe () - "Supercite version 2.3 is now described in a texinfo manual which -makes the documentation available both for online perusal via emacs' -info system, or for hard-copy printing using the TeX facility. - -To view the online document hit \\[info], then \"mSupercite <RET>\"." - (interactive) - (describe-function 'sc-describe)) - -;; ====================================================================== -;; load hook -(run-hooks 'sc-load-hook) -(provide 'sc)
--- a/lisp/=setaddr.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,71 +0,0 @@ -;;; setaddr.el --- determine whether sendmail is configured on this machine - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: mail - -;; 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: - -;; If neither sendmail nor Emacs knows what host address to use -;; for this machine, ask for it, and save it in site-start.el -;; so we won't have to ask again. - -;; This uses a heuristic about the output from sendmail -;; which may or may not really work. We will have to find -;; out by experiment. - -;;; Code: - -(or mail-host-address - (let (sendmail-configured) - (with-temp-buffer " mail-host-address" - (call-process sendmail-program nil t nil "-bv" "root") - (goto-char (point-min)) - (setq sendmail-configured (looking-at "root@"))) - (or sendmail-configured - (let (buffer) - (setq mail-host-address - (read-string "Specify your host's fully qualified domain name: "))) - ;; Create an init file, and if we just read mail-host-address, - ;; make the init file set it. - (unwind-protect - (save-excursion - (set-buffer (find-file-noselect "site-start.el")) - (setq buffer (current-buffer)) - ;; Get rid of the line that ran this file. - (if (search-forward "(load \"setaddr\")\n") - (progn - (beginning-of-line) - (delete-region (point) - (progn (end-of-line) - (point))))) - ;; Add the results - (goto-char (point-max)) - (insert "\n(setq mail-host-address " - (prin1-to-string mail-host-address) - ")\n") - (condition-case nil - (save-buffer) - (file-error nil))) - (if buffer - (kill-buffer buffer)))))) - -;;; setaddr.el ends here
--- a/lisp/=speedbspec.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,133 +0,0 @@ -;;; speedbspec --- Buffer specialized configurations for speedbar - -;; Copyright (C) 1997, 1998 Free Software Foundation -;; -;; Author: Eric M. Ludlam <zappo@gnu.ai.mit.edu> -;; Version: 0.2 -;; Keywords: file, tags, tools -;; -;; 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: -;; -;; Speedbar provides a frame in which files, and locations in -;; files are displayed. These functions provide some mode-specific -;; displays for some existing emacs modes. -;; -;; To provide special service to all the modes supported by this file, -;; put the following in your .emacs file. -;; -;; (require 'speedbspec) -;; -;; This will load in the known functions, and the mode-enabling code -;; into 'change-major-mode-hook. -;; -;; You can interactivly try to enable speedbar specialized modes by -;; calling the function `speedbar-add-localized-speedbar-support' and -;; disable it with `speedbar-remove-localized-speedbar-support'. -;; -;; This file requires speedbar. - -;;; Change log: -;; 0.1 - Initial revision requiring speedbar 0.5 -;; 0.1.1 - `buffer-live-p' replacement on old emacsen -;; 0.2 - Moved actual work code into their own files. -;; Check and load files that need loading before checking for the -;; menu variable. -;; Made the functions to turn on/off speedbar support interactive. -;; It is *not* a minor-mode, it mearly enables special speedbar -;; behaviors. -;; 0.2.1 - Fix for emacs 20 when checking for autoload functions. - -;;; Code: -(require 'speedbar) - -;;; Compatibility: -;; -;; Thanks: ptype@dra.hmg.gb -(if (fboundp 'buffer-live-p) - nil - (defun buffer-live-p (buffer) - "Determine if the buffer is alive." - (memq buffer (buffer-list)))) - - -;;; Generic add-new-special-mode stuff -;; -(defvar speedbar-localized-buffer-queue nil - "List of buffers to localize for speedbar.") - -(defun speedbar-add-localized-speedbar-support-to-q () - "Add speedbar support to all buffers in `speedbar-localized-buffer-queue'." - (remove-hook 'post-command-hook - 'speedbar-add-localized-speedbar-support-to-q) - (while speedbar-localized-buffer-queue - (speedbar-add-localized-speedbar-support - (car speedbar-localized-buffer-queue)) - (setq speedbar-localized-buffer-queue - (cdr speedbar-localized-buffer-queue)))) - -(defun speedbar-add-localized-speedbar-support (buffer) - "Add localized speedbar support to BUFFER's mode if it is available." - (interactive "bBuffer: ") - (if (stringp buffer) (setq buffer (get-buffer buffer))) - (if (not (buffer-live-p buffer)) - nil - (save-excursion - (set-buffer buffer) - (save-match-data - (let ((ms (symbol-name major-mode)) - v tmp) - (if (not (string-match "-mode$" ms)) - nil ;; do nothing to broken mode - (setq ms (substring ms 0 (match-beginning 0))) - (setq v (intern-soft (concat ms "-speedbar-buttons"))) - (if (not v) - nil ;; do nothing if not defined - ;; If it is autoloaded, we need to load it now so that - ;; we have access to the varialbe -speedbar-menu-items. - ;; Is this XEmacs safe? - (let ((sf (symbol-function v))) - (if (and (listp sf) (eq (car sf) 'autoload)) - (load-library (car (cdr sf))))) - (set (make-local-variable 'speedbar-special-mode-expansion-list) - (list v)) - (setq v (intern-soft (concat ms "-speedbar-menu-items"))) - (if (not v) - nil ;; don't add special menus - (make-local-variable 'speedbar-easymenu-definition-special) - (setq speedbar-easymenu-definition-special - (symbol-value v)))))))))) - -(defun speedbar-remove-localized-speedbar-support (buffer) - "Remove any traces that BUFFER supports speedbar in a specialized way." - (save-excursion - (set-buffer buffer) - (kill-local-variable 'speedbar-special-mode-expansion-list) - (kill-local-variable 'speedbar-easymenu-definition-special))) - -(defun speedbar-change-major-mode () - "Run when the major mode is changed." - (setq speedbar-localized-buffer-queue - (add-to-list 'speedbar-localized-buffer-queue (current-buffer))) - (add-hook 'post-command-hook 'speedbar-add-localized-speedbar-support-to-q)) - -(add-hook 'change-major-mode-hook 'speedbar-change-major-mode) -(add-hook 'find-file-hooks 'speedbar-change-major-mode) - -(provide 'speedbspec) -;;; speedbspec ends here
--- a/lisp/=sun-keys.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -;;; sun-keys.el --- support for Sun function keys - -;;; Copyright (C) 1986 Free Software Foundation, Inc. - -;; Author: Ian G. Batten <batten@uk.ac.bham.multics> -;; Keywords: terminals - -;;; 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: - -;;; Support (cleanly) for Sun function keys. Provides help facilities, -;;; better diagnostics, etc. -;;; -;;; To use: make sure your .ttyswrc binds 'F1' to <ESC> * F1 <CR> and so on. -;;; load this lot from your start_up - -;;; Code: - -(defun sun-function-keys-dispatch (arg) - "Dispatcher for function keys." - (interactive "p") - (let* ((key-stroke (read t)) - (command (assq key-stroke sun-function-keys-command-list))) - (cond (command (funcall (cdr command) arg)) - (t (error "Unbound function key %s" key-stroke))))) - -(defvar sun-function-keys-command-list - '((F1 . sun-function-keys-describe-bindings) - (R8 . previous-line) ; arrow keys - (R10 . backward-char) - (R12 . forward-char) - (R14 . next-line))) - -(defun sun-function-keys-bind-key (arg1 arg2) - "Bind a specified key." - (interactive "xFunction Key Cap Label: -CCommand To Use:") - (setq sun-function-keys-command-list - (cons (cons arg1 arg2) sun-function-keys-command-list))) - -(defun sun-function-keys-describe-bindings (arg) - "Describe the function key bindings we're running" - (interactive) - (with-output-to-temp-buffer "*Help*" - (sun-function-keys-write-bindings - (sort (copy-sequence sun-function-keys-command-list) - '(lambda (x y) (string-lessp (car x) (car y))))))) - -(defun sun-function-keys-write-bindings (list) - (cond ((null list) - t) - (t - (princ (format "%s: %s\n" - (car (car list)) - (cdr (car list)))) - (sun-function-keys-write-bindings (cdr list))))) - -(global-set-key "\e*" 'sun-function-keys-dispatch) - -(make-variable-buffer-local 'sun-function-keys-command-list) - -;;; sun-keys.el ends here
--- a/lisp/=superyank.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1243 +0,0 @@ -;;; superyank.el --- smart message-yanking code for GNUS - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Barry A. Warsaw <warsaw@cme.nist.gov> -;; Version: 1.1 -;; Adapted-By: ESR -;; Keywords: news - -;; 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: - -;; Inserts the message being replied to with various user controlled -;; citation styles. -;; - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; this file, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - -;; NAME: Barry A. Warsaw USMAIL: National Institute of Standards -;; TELE: (301) 975-3460 and Technology (formerly NBS) -;; UUCP: {...}!uunet!cme-durer!warsaw Rm. B-124, Bldg. 220 -;; ARPA: warsaw@cme.nist.gov Gaithersburg, MD 20899 - -;; Modification history: -;; -;; modified: 14-Jun-1989 baw (better keymap set procedure, rewrite-headers) -;; modified: 12-Jun-1989 baw (added defvar for sy-use-only-preference-p) -;; modified: 6-Jun-1989 baw (better sy-rewrite-headers, no kill/yank) -;; modified: 5-Jun-1989 baw (requires rnewspost.el) -;; modified: 1-Jun-1989 baw (persistent attribution, sy-open-line) -;; modified: 31-May-1989 baw (fixed some gnus problems, id'd another) -;; modified: 22-May-1989 baw (documentation) -;; modified: 8-May-1989 baw (auto filling of regions) -;; modified: 1-May-1989 baw (documentation) -;; modified: 27-Apr-1989 baw (new preference scheme) -;; modified: 24-Apr-1989 baw (remove gnus headers, attrib scheme, cite lines) -;; modified: 19-Apr-1989 baw (cite key, fill p, yank region, naming scheme) -;; modified: 12-Apr-1989 baw (incorp other mail yank features seen on net) -;; created : 16-Feb-1989 baw (mod vanilla fn indent-rigidly mail-yank-original) - -;; Though I wrote this package basically from scratch, as an Emacs Lisp -;; learning exercise, it was inspired by postings of similar packages to -;; the gnu.emacs newsgroup over the past month or so. -;; -;; Here's a brief history of how this package developed: -;; -;; I as well as others on the net were pretty unhappy about the way emacs -;; cited replies with the tab or 4 spaces. It looked ugly and made it hard -;; to distinguish between original and cited lines. I hacked on the function -;; yank-original to at least give the user the ability to define the citation -;; character. I posted this simple hack, and others did as well. The main -;; difference between mine and others was that a space was put after the -;; citation string on on new citations, but not after previously cited lines: -;; -;; >> John wrote this originally -;; > Jane replied to that -;; -;; Then Martin Neitzel posted some code that he developed, derived in part -;; from code that Ashwin Ram posted previous to that. In Martin's -;; posting, he introduced a new, and (IMHO) superior, citation style, -;; eliminating nested citations. Yes, I wanted to join the Small-But- -;; Growing-Help-Stamp-Out-Nested-Citation-Movement! You should too. -;; -;; But Martin's code simply asks the user for the citation string (here -;; after called the `attribution' string), and I got to thinking, it wouldn't -;; be that difficult to automate that part. So I started hacking this out. -;; It proved to be not as simple as I first thought. But anyway here it -;; is. See the wish list below for future plans (if I have time). -;; -;; Type "C-h f mail-yank-original" after this package is loaded to get a -;; description of what it does and the variables that control it. -;; -;; ====================================================================== -;; -;; Changes wish list -;; -;; 1) C-x C-s yanks a region from the RMAIL buffer instead of the -;; whole buffer -;; -;; 2) reparse nested citations to try to recast as non-nested citations -;; perhaps by checking the References: line -;; - -;;; Code: - -;; ====================================================================== -;; -;; require and provide features -;; -(require 'sendmail) -;; -;; ====================================================================== -;; -;; don't need rnewspost.el to rewrite the header. This only works -;; with diffs to rnewspost.el that I posted with the original -;; superyank code. -;; -(setq news-reply-header-hook nil) - -;; ********************************************************************** -;; start of user defined variables -;; ********************************************************************** -;; -;; this section defines variables that control the operation of -;; super-mail-yank. Most of these are described in the comment section -;; as well as the DOCSTRING. -;; - -;; -;; ---------------------------------------------------------------------- -;; -;; this variable holds the default author's name for citations -;; -(defvar sy-default-attribution "Anon" - "String that describes attribution to unknown person. This string -should not contain the citation string.") - -;; -;; ---------------------------------------------------------------------- -;; -;; string used as an end delimiter for both nested and non-nested citations -;; -(defvar sy-citation-string ">" - "String to use as an end-delimiter for citations. This string is -used in both nested and non-nested citations. For best results, use a -single character with no trailing space. Most commonly used string -is: \">\.") - -;; -;; ---------------------------------------------------------------------- -;; -;; variable controlling citation type, nested or non-nested -;; -(defvar sy-nested-citation-p nil - "Non-nil uses nested citations, nil uses non-nested citations. -Nested citations are of the style: - -I wrote this -> He wrote this ->> She replied to something he wrote - -Non-nested citations are of the style: - -I wrote this -John> He wrote this -Jane> She originally wrote this") - - -;; -;; ---------------------------------------------------------------------- -;; -;; regular expression that matches existing citations -;; -(defvar sy-cite-regexp "[a-zA-Z0-9]*>" - "Regular expression that describes how an already cited line in an -article begins. The regexp is only used at the beginning of a line, -so it doesn't need to begin with a '^'.") - -;; -;; ---------------------------------------------------------------------- -;; -;; regular expression that delimits names from titles in the field that -;; looks like: (John X. Doe -- Computer Hacker Extraordinaire) -;; -(defvar sy-titlecue-regexp "\\s +-+\\s +" - - "Regular expression that delineates names from titles in the name -field. Often, people will set up their name field to look like this: - -(John Xavier Doe -- Computer Hacker Extraordinaire) - -Set to nil to treat entire field as a name.") - -;; -;; ---------------------------------------------------------------------- -;; -;; -(defvar sy-preferred-attribution 2 - - "This is an integer indicating what the user's preference is in -attribution style, based on the following key: - -0: email address name is preferred -1: initials are preferred -2: first name is preferred -3: last name is preferred - -The value of this variable may also be greater than 3, which would -allow you to prefer the 2nd through nth - 1 name. If the preferred -attribution is nil or the empty string, then the secondary preferrence -will be the first name. After that, the entire name alist is search -until a non-empty, non-nil name is found. If no such name is found, -then the user is either queried or the default attribution string is -used depending on the value of sy-confirm-always-p. - -Examples: - -assume the from: line looks like this: - -from: doe@computer.some.where.com (John Xavier Doe) - -The following preferences would return these strings: - -0: \"doe\" -1: \"JXD\" -2: \"John\" -3: \"Doe\" -4: \"Xavier\" - -anything else would return \"John\".") - -;; -;; ---------------------------------------------------------------------- -;; -(defvar sy-confirm-always-p t - "If t, always confirm attribution string before inserting into -buffer.") - - -;; -;; ---------------------------------------------------------------------- -;; -;; informative header hook -;; -(defvar sy-rewrite-header-hook 'sy-header-on-said - "Hook for inserting informative header at the top of the yanked -message. Set to nil for no header. Here is a list of predefined -header styles; you can use these as a model to write you own: - -sy-header-on-said [default]: On 14-Jun-1989 GMT, - John Xavier Doe said: - -sy-header-inarticle-writes: In article <123456789> John Xavier Doe writes: - -sy-header-regarding-writes: Regarding RE: superyank; John Xavier Doe adds: - -sy-header-verbose: On 14-Jun-1989 GMT, John Xavier Doe - from the organization Great Company - has this to say about article <123456789> - in newsgroups misc.misc - concerning RE: superyank - referring to previous articles <987654321> - -You can use the following variables as information strings in your header: - -sy-reply-yank-date: the date field [ex: 14-Jun-1989 GMT] -sy-reply-yank-from: the from field [ex: John Xavier Doe] -sy-reply-yank-message-id: the message id [ex: <123456789>] -sy-reply-yank-subject: the subject line [ex: RE: superyank] -sy-reply-yank-newsgroup: the newsgroup name for GNUS [ex: misc.misc] -sy-reply-yank-references: the article references [ex: <987654321>] -sy-reply-yank-organization: the author's organization [ex: Great Company] - -If a field can't be found, because it doesn't exist or is not being -shown, perhaps because of toggle-headers, the corresponding field -variable will contain the string \"mumble mumble\".") - -;; -;; ---------------------------------------------------------------------- -;; -;; non-nil means downcase the author's name string -;; -(defvar sy-downcase-p nil - "Non-nil means downcase the author's name string.") - -;; -;; ---------------------------------------------------------------------- -;; -;; controls removal of leading white spaces -;; -(defvar sy-left-justify-p nil - "If non-nil, delete all leading white space before citing.") - -;; -;; ---------------------------------------------------------------------- -;; -;; controls auto filling of region -;; -(defvar sy-auto-fill-region-p nil - "If non-nil, automatically fill each paragraph that is cited. If -nil, do not auto fill each paragraph.") - - -;; -;; ---------------------------------------------------------------------- -;; -;; controls use of preferred attribution only, or use of attribution search -;; scheme if the preferred attrib can't be found. -;; -(defvar sy-use-only-preference-p nil - - "If non-nil, then only the preferred attribution string will be -used. If the preferred attribution string can not be found, then the -sy-default-attribution will be used. If nil, and the preferred -attribution string is not found, then some secondary scheme will be -employed to find a suitable attribution string.") - -;; ********************************************************************** -;; end of user defined variables -;; ********************************************************************** - -;; -;; ---------------------------------------------------------------------- -;; -;; The new citation style means we can clean out other headers in addition -;; to those previously cleaned out. Anyway, we create our own headers. -;; Also, we want to clean out any headers that gnus puts in. Add to this -;; for other mail or news readers you may be using. -;; -(setq mail-yank-ignored-headers "^via:\\|^origin:\\|^status:\\|^re\\(mail\\|ceiv\\)ed\\|^[a-z-]*message-id:\\|^\\(summary-\\)?line[s]?:\\|^cc:\\|^subject:\\|^\\(\\(in-\\)?reply-\\)?to:\\|^\\(\\(return\\|reply\\)-\\)?path:\\|^\\(posted-\\)?date:\\|^\\(mail-\\)?from:\\|^newsgroup[s]?:\\|^organization:\\|^keywords:\\|^distribution:\\|^references:") - -;; -;; ---------------------------------------------------------------------- -;; -;; global variables, not user accessable -;; -(setq sy-persist-attribution (concat sy-default-attribution "> ")) -(setq sy-reply-yank-date "") -(setq sy-reply-yank-from "") -(setq sy-reply-yank-message-id "") -(setq sy-reply-yank-subject "") -(setq sy-reply-yank-newsgroups "") -(setq sy-reply-yank-references "") -(setq sy-reply-yank-organization "") - -;; -;; ====================================================================== -;; -;; This section contains primitive functions used in the schemes. They -;; extract name fields from various parts of the "from:" field based on -;; the control variables described above. -;; -;; Some will use recursion to pick out the correct namefield in the namestring -;; or the list of initials. These functions all scan a string that contains -;; the name, ie: "John Xavier Doe". There is no limit on the number of names -;; in the string. Also note that all white spaces are basically ignored and -;; are stripped from the returned strings, and titles are ignored if -;; sy-titlecue-regexp is set to non-nil. -;; -;; Others will use methods to try to extract the name from the email -;; address of the originator. The types of addresses readable are -;; described above. - -;; -;; ---------------------------------------------------------------------- -;; -;; try to extract the name from an email address of the form -;; name%[stuff] -;; -;; Unlike the get-name functions above, these functions operate on the -;; buffer instead of a supplied name-string. -;; -(defun sy-%-style-address () - (beginning-of-line) - (buffer-substring - (progn (re-search-forward "%" (point-max) t) - (if (not (bolp)) (forward-char -1)) - (point)) - (progn (re-search-backward "^\\|[^a-zA-Z0-9]") - (point)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; try to extract names from addresses with the form: -;; [stuff]name@[stuff] -;; -(defun sy-@-style-address () - (beginning-of-line) - (buffer-substring - (progn (re-search-forward "@" (point-max) t) - (if (not (bolp)) (forward-char -1)) - (point)) - (progn (re-search-backward "^\\|[^a-zA-Z0-0]") - (if (not (bolp)) (forward-char 1)) - (point)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; try to extract the name from addresses with the form: -;; [stuff]![stuff]...!name[stuff] -;; -(defun sy-!-style-address () - (beginning-of-line) - (buffer-substring - (progn (while (re-search-forward "!" (point-max) t)) - (point)) - (progn (re-search-forward "[^a-zA-Z0-9]\\|$") - (if (not (eolp)) (forward-char -1)) - (point)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; using the different email name schemes, try each one until you get a -;; non-nil entry -;; -(defun sy-get-emailname () - (let ((en1 (sy-%-style-address)) - (en2 (sy-@-style-address)) - (en3 (sy-!-style-address))) - (cond - ((not (string-equal en1 "")) en1) - ((not (string-equal en2 "")) en2) - ((not (string-equal en3 "")) en3) - (t "")))) - -;; -;; ---------------------------------------------------------------------- -;; -;; returns the "car" of the namestring, really the first namefield -;; -;; (sy-string-car "John Xavier Doe") -;; => "John" -;; -(defun sy-string-car (namestring) - (substring namestring - (progn (string-match "\\s *" namestring) (match-end 0)) - (progn (string-match "\\s *\\S +" namestring) (match-end 0)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; returns the "cdr" of the namestring, really the whole string from -;; after the first name field to the end of the string. -;; -;; (sy-string-cdr "John Xavier Doe") -;; => "Xavier Doe" -;; -(defun sy-string-cdr (namestring) - (substring namestring - (progn (string-match "\\s *\\S +\\s *" namestring) - (match-end 0)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; convert a namestring to a list of namefields -;; -;; (sy-namestring-to-list "John Xavier Doe") -;; => ("John" "Xavier" "Doe") -;; -(defun sy-namestring-to-list (namestring) - (if (not (string-match namestring "")) - (append (list (sy-string-car namestring)) - (sy-namestring-to-list (sy-string-cdr namestring))))) - -;; -;; ---------------------------------------------------------------------- -;; -;; strip the initials from each item in the list and return a string -;; that is the concatenation of the initials -;; -(defun sy-strip-initials (raw-nlist) - (if (not raw-nlist) - nil - (concat (substring (car raw-nlist) 0 1) - (sy-strip-initials (cdr raw-nlist))))) - - -;; -;; ---------------------------------------------------------------------- -;; -;; using the namestring, build a list which is in the following order -;; -;; (email, initials, firstname, lastname, name1, name2, name3 ... nameN-1) -;; -(defun sy-build-ordered-namelist (namestring) - (let* ((raw-nlist (sy-namestring-to-list namestring)) - (initials (sy-strip-initials raw-nlist)) - (firstname (car raw-nlist)) - (revnames (reverse (cdr raw-nlist))) - (lastname (car revnames)) - (midnames (reverse (cdr revnames))) - (emailnames (sy-get-emailname))) - (append (list emailnames) - (list initials) - (list firstname) - (list lastname) - midnames))) - -;; -;; ---------------------------------------------------------------------- -;; -;; Query the user for the attribution string. Supply sy-default-attribution -;; as the default choice. -;; -(defun sy-query-for-attribution () - (concat - (let* ((prompt (concat "Enter attribution string: (default " - sy-default-attribution - ") ")) - (query (read-input prompt)) - (attribution (if (string-equal query "") - sy-default-attribution - query))) - (if sy-downcase-p - (downcase attribution) - attribution)) - sy-citation-string)) - - -;; -;; ---------------------------------------------------------------------- -;; -;; parse the current line for the namestring -;; -(defun sy-get-namestring () - (save-restriction - (beginning-of-line) - (if (re-search-forward "(.*)" (point-max) t) - (let ((start (progn - (beginning-of-line) - (re-search-forward "\\((\\s *\\)\\|$" (point-max) t) - (point))) - (end (progn - (re-search-forward - (concat "\\(\\s *\\()\\|" sy-titlecue-regexp "\\)\\)\\|$") - (point-max) t) - (point)))) - (narrow-to-region start end) - (let ((start (progn - (beginning-of-line) - (point))) - (end (progn - (end-of-line) - (re-search-backward - (concat "\\s *\\()\\|" sy-titlecue-regexp "\\)$") - (point-min) t) - (point)))) - (buffer-substring start end))) - (let ((start (progn - (beginning-of-line) - (re-search-forward "^\"*") - (point))) - (end (progn - (re-search-forward "\\(\\s *[a-zA-Z0-9\\.]+\\)*" - (point-max) t) - (point)))) - (buffer-substring start end))))) - - -;; -;; ---------------------------------------------------------------------- -;; -;; scan the nlist and return the integer pointing to the first legal -;; non-empty namestring. Returns the integer pointing to the index -;; in the nlist of the preferred namestring, or nil if no legal -;; non-empty namestring could be found. -;; -(defun sy-return-preference-n (nlist) - (let ((p sy-preferred-attribution) - (exception nil)) - ;; - ;; check to be sure the index is not out-of-bounds - ;; - (cond - ((< p 0) (setq p 2) (setq exception t)) - ((not (nth p nlist)) (setq p 2) (setq exception t))) - ;; - ;; check to be sure that the explicit preference is not empty - ;; - (if (string-equal (nth p nlist) "") - (progn (setq p 0) - (setq exception t))) - ;; - ;; find the first non-empty namestring - ;; - (while (and (nth p nlist) - (string-equal (nth p nlist) "")) - (setq exception t) - (setq p (+ p 1))) - ;; - ;; return the preference index if non-nil, otherwise nil - ;; - (if (or (and exception sy-use-only-preference-p) - (not (nth p nlist))) - nil - p))) - -;; -;; -;; ---------------------------------------------------------------------- -;; -;; rebuild the nlist into an alist for completing-read. Use as a guide -;; the index of the preferred name field. Get the actual preferred -;; name field base on other factors (see above). If no actual preferred -;; name field is found, then query the user for the attribution string. -;; -;; also note that the nlist is guaranteed to be non-empty. At the very -;; least it will consist of 4 empty strings ("" "" "" "") -;; -(defun sy-nlist-to-alist (nlist) - (let ((preference (sy-return-preference-n nlist)) - alist - (n 0)) - ;; - ;; check to be sure preference is not nil - ;; - (if (not preference) - (setq alist (list (cons (sy-query-for-attribution) nil))) - ;; - ;; preference is non-nil - ;; - (setq alist (list (cons (nth preference nlist) nil))) - (while (nth n nlist) - (if (= n preference) nil - (setq alist (append alist (list (cons (nth n nlist) nil))))) - (setq n (+ n 1)))) - alist)) - - - -;; -;; ---------------------------------------------------------------------- -;; -;; confirm if desired after the alist has been built -;; -(defun sy-get-attribution (alist) - (concat - ;; - ;; check to see if nested citations are to be used - ;; - (if sy-nested-citation-p - "" - ;; - ;; check to see if confirmation is needed - ;; if not, just return the preference (first element in alist) - ;; - (if (not sy-confirm-always-p) - (car (car alist)) - ;; - ;; confirmation is requested so build the prompt, confirm - ;; and return the chosen string - ;; - (let* (ignore - (prompt (concat "Complete attribution string: (default " - (car (car alist)) - ") ")) - ;; - ;; set up the local completion keymap - ;; - (minibuffer-local-must-match-map - (let ((map (make-sparse-keymap))) - (define-key map "?" 'minibuffer-completion-help) - (define-key map " " 'minibuffer-complete-word) - (define-key map "\t" 'minibuffer-complete) - (define-key map "\00A" 'exit-minibuffer) - (define-key map "\00D" 'exit-minibuffer) - (define-key map "\007" - '(lambda () - (interactive) - (beep) - (exit-minibuffer))) - map)) - ;; - ;; read the completion - ;; - (attribution (completing-read prompt alist)) - ;; - ;; check attribution string for emptyness - ;; - (choice (if (or (not attribution) - (string-equal attribution "")) - (car (car alist)) - attribution))) - - (if sy-downcase-p - (downcase choice) - choice)))) - sy-citation-string)) - - -;; -;; ---------------------------------------------------------------------- -;; -;; this function will scan the current rmail buffer, narrowing it to the -;; from: line, then using this, it will try to decipher some names from -;; that line. It will then build the name alist and try to confirm -;; its choice of attribution strings. It returns the chosen attribution -;; string. -;; -(defun sy-scan-rmail-for-names (rmailbuffer) - (save-excursion - (let ((case-fold-search t) - alist - attribution) - (switch-to-buffer rmailbuffer) - (goto-char (point-min)) - ;; - ;; be sure there is a from: line - ;; - (if (not (re-search-forward "^from:\\s *" (point-max) t)) - (setq attribution (sy-query-for-attribution)) - ;; - ;; if there is a from: line, then scan the narrow the buffer, - ;; grab the namestring, and build the alist, then using this - ;; get the attribution string. - ;; - (save-restriction - (narrow-to-region (point) - (progn (end-of-line) (point))) - (let* ((namestring (sy-get-namestring)) - (nlist (sy-build-ordered-namelist namestring))) - (setq alist (sy-nlist-to-alist nlist)))) - ;; - ;; we've built the alist, now confirm the attribution choice - ;; if appropriate - ;; - (setq attribution (sy-get-attribution alist))) - attribution))) - - -;; -;; ====================================================================== -;; -;; the following function insert of citations, writing of headers, filling -;; paragraphs and general higher level operations -;; - -;; -;; ---------------------------------------------------------------------- -;; -;; insert a nested citation -;; -(defun sy-insert-citation (start end cite-string) - (save-excursion - (goto-char end) - (setq end (point-marker)) - (goto-char start) - (or (bolp) - (forward-line 1)) - - (let ((fill-prefix (concat cite-string " ")) - (fstart (point)) - (fend (point))) - - (while (< (point) end) - ;; - ;; remove leading tabs if desired - ;; - (if sy-left-justify-p - (delete-region (point) - (progn (skip-chars-forward " \t") (point)))) - ;; - ;; check to see if the current line should be cited - ;; - (if (or (eolp) - (looking-at sy-cite-regexp)) - ;; - ;; do not cite this line unless nested-citations are to be - ;; used - ;; - (progn - (or (eolp) - (if sy-nested-citation-p - (insert cite-string))) - - ;; set fill start and end points - ;; - (or (= fstart fend) - (not sy-auto-fill-region-p) - (progn (goto-char fend) - (or (not (eolp)) - (setq fend (+ fend 1))) - (fill-region-as-paragraph fstart fend))) - (setq fstart (point)) - (setq fend (point))) - - ;; else - ;; - (insert fill-prefix) - (end-of-line) - (setq fend (point))) - - (forward-line 1))) - (move-marker end nil))) - -;; -;; ---------------------------------------------------------------------- -;; -;; yank a particular field into a holding variable -;; -(defun sy-yank-fields (start) - (save-excursion - (goto-char start) - (setq sy-reply-yank-date (mail-fetch-field "date") - sy-reply-yank-from (mail-fetch-field "from") - sy-reply-yank-subject (mail-fetch-field "subject") - sy-reply-yank-newsgroups (mail-fetch-field "newsgroups") - sy-reply-yank-references (mail-fetch-field "references") - sy-reply-yank-message-id (mail-fetch-field "message-id") - sy-reply-yank-organization (mail-fetch-field "organization")) - (or sy-reply-yank-date - (setq sy-reply-yank-date "mumble mumble")) - (or sy-reply-yank-from - (setq sy-reply-yank-from "mumble mumble")) - (or sy-reply-yank-subject - (setq sy-reply-yank-subject "mumble mumble")) - (or sy-reply-yank-newsgroups - (setq sy-reply-yank-newsgroups "mumble mumble")) - (or sy-reply-yank-references - (setq sy-reply-yank-references "mumble mumble")) - (or sy-reply-yank-message-id - (setq sy-reply-yank-message-id "mumble mumble")) - (or sy-reply-yank-organization - (setq sy-reply-yank-organization "mumble mumble")))) - -;; -;; ---------------------------------------------------------------------- -;; -;; rewrite the header to be more conversational -;; -(defun sy-rewrite-headers (start) - (goto-char start) - (run-hooks 'sy-rewrite-header-hook)) - -;; -;; ---------------------------------------------------------------------- -;; -;; some different styles of headers -;; -(defun sy-header-on-said () - (insert-string "\nOn " sy-reply-yank-date ",\n" - sy-reply-yank-from " said:\n")) - -(defun sy-header-inarticle-writes () - (insert-string "\nIn article " sy-reply-yank-message-id - " " sy-reply-yank-from " writes:\n")) - -(defun sy-header-regarding-writes () - (insert-string "\nRegarding " sy-reply-yank-subject - "; " sy-reply-yank-from " adds:\n")) - -(defun sy-header-verbose () - (insert-string "\nOn " sy-reply-yank-date ",\n" - sy-reply-yank-from "\nfrom the organization " - sy-reply-yank-organization "\nhad this to say about article " - sy-reply-yank-message-id "\nin newsgroups " - sy-reply-yank-newsgroups "\nconcerning " - sy-reply-yank-subject "\nreferring to previous articles " - sy-reply-yank-references "\n")) - -;; -;; ---------------------------------------------------------------------- -;; -;; yank the original article in and attribute -;; -(defun sy-yank-original (arg) - - "Insert the message being replied to, if any (in rmail/gnus). Puts -point before the text and mark after. Calls generalized citation -function sy-insert-citation to cite all allowable lines." - - (interactive "P") - (if mail-reply-buffer - (let* ((sy-confirm-always-p (if (consp arg) - t - sy-confirm-always-p)) - (attribution (sy-scan-rmail-for-names mail-reply-buffer)) - (top (point)) - (start (point)) - (end (progn (delete-windows-on mail-reply-buffer) - (insert-buffer mail-reply-buffer) - (mark)))) - - (sy-yank-fields start) - (sy-rewrite-headers start) - (setq start (point)) - (mail-yank-clear-headers top (mark)) - (setq sy-persist-attribution (concat attribution " ")) - (sy-insert-citation start end attribution)) - - (goto-char top) - (exchange-point-and-mark))) - - -;; -;; ---------------------------------------------------------------------- -;; -;; this is here for compatibility with existing mail/news yankers -;; overloads the default mail-yank-original -;; -(defun mail-yank-original (arg) - - "Yank original message buffer into the reply buffer, citing as per -user preferences. Numeric Argument forces confirmation. - -Here is a description of the superyank.el package, what it does and -what variables control its operation. This was written by Barry -Warsaw (warsaw@cme.nist.gov, {...}!uunet!cme-durer!warsaw). - -A 'Citation' is the acknowledgement of the original author of a mail -message. There are two general forms of citation. In 'nested -citations', indication is made that the cited line was written by -someone *other* that the current message author (or by that author at -an earlier time). No indication is made as to the identity of the -original author. Thus, a nested citation after multiple replies would -look like this (this is after my reply to a previous message): - ->>John originally wrote this ->>and this as well -> Jane said that John didn't know -> what he was talking about -And that's what I think as well. - -In non-nested citations, you won't see multiple \">\" characters at -the beginning of the line. Non-nested citations will insert an -informative string at the beginning of a cited line, attributing that -line to an author. The same message described above might look like -this if non-nested citations were used: - -John> John originally wrote this -John> and this as well -Jane> Jane said that John didn't know -Jane> what he was talking about -And that's what I think as well. - -Notice that my inclusion of Jane's inclusion of John's original -message did not result in a cited line of the form: Jane>John>. Thus -no nested citations. The style of citation is controlled by the -variable `sy-nested-citation-p'. Nil uses non-nested citations and -non-nil uses old style, nested citations. - -The variable `sy-citation-string' is the string to use as a marker for -a citation, either nested or non-nested. For best results, this -string should be a single character with no trailing space and is -typically the character \">\". In non-nested citations this string is -appended to the attribution string (author's name), along with a -trailing space. In nested citations, a trailing space is only added -to a first level citation. - -Another important variable is `sy-cite-regexp' which describes strings -that indicate a previously cited line. This regular expression is -always used at the beginning of a line so it doesn't need to begin -with a \"^\" character. Change this variable if you change -`sy-citation-string'. - -The following section only applies to non-nested citations. - -This package has a fair amount of intellegence related to deciphering -the author's name based on information provided by the original -message buffer. In normal operation, the program will pick out the -author's first and last names, initials, terminal email address and -any other names it can find. It will then pick an attribution string -from this list based on a user defined preference and it will ask for -confirmation if the user specifies. This package gathers its -information from the `From:' line of the original message buffer. It -recognizes From: lines with the following forms: - -From: John Xavier Doe <doe@speedy.computer.com> -From: \"John Xavier Doe\" <doe@speedy.computer.com> -From: doe@speedy.computer.com (John Xavier Doe) -From: computer!speedy!doe (John Xavier Doe) -From: computer!speedy!doe (John Xavier Doe) -From: doe%speedy@computer.com (John Xavier Doe) - -In this case, if confirmation is requested, the following strings will -be made available for completion and confirmation: - -\"John\" -\"Xavier\" -\"Doe\" -\"JXD\" -\"doe\" - -Note that completion is case sensitive. If there was a problem -picking out a From: line, or any other problem getting even a single -name, then the user will be queried for an attribution string. The -default attribution string is set in the variable -`sy-default-attribution'. - -Sometimes people set their name fields so that it also includes a -title of the form: - -From: doe@speedy.computer.com (John Doe -- Hacker Extraordinaire) - -To avoid the inclusion of the string \"-- Hacker Extraordinaire\" in -the name list, the variable `sy-titlecue-regexp' is provided. Its -default setting will still properly recognize names of the form: - -From: xdoe@speedy.computer.com (John Xavier-Doe -- Crazed Hacker) - -The variable `sy-preferred-attribution' contains an integer that -indicates which name field the user prefers to use as the attribution -string, based on the following key: - -0: email address name is preferred -1: initials are preferred -2: first name is preferred -3: last name is preferred - -The value can be greater than 3, in which case, you would be -preferring the 2nd throught nth -1 name. In any case, if the -preferred name can't be found, then one of two actions will be taken -depending on the value of the variable `sy-use-only-preference-p'. If -this is non-nil, then the `sy-default-attribution will be used. If it -is nil, then a secondary scheme will be employed to find a suitable -attribution scheme. First, the author's first name will be used. If -that can't be found than the name list is searched for the first -non-nil, non-empty name string. If still no name can be found, then -the user is either queried, or the `sy-default-attribution' is used, -depending on the value of `sy-confirm-always-p'. - -If the variable `sy-confirm-always-p' is non-nil, superyank will always -confirm the attribution string with the user before inserting it into -the reply buffer. Confirmation is with completion, but the completion -list is merely a suggestion; the user can override the list by typing -in a string of their choice. - -The variable `sy-rewrite-header-hook' is a hook that contains a lambda -expression which rewrites the informative header at the top of the -yanked message. Set to nil to avoid writing any header. - -You can make superyank autofill each paragraph it cites by setting the -variable `sy-auto-fill-region-p' to non-nil. Or set the variable to nil -and fill the paragraphs manually with sy-fill-paragraph-manually (see -below). - -Finally, `sy-downcase-p' if non-nil, indicates that you always want to -downcase the attribution string before insertion, and -`sy-left-justify-p', if non-nil, indicates that you want to delete all -leading white space before citing. - -Since the almost all yanking in other modes (RMAIL, GNUS) is done -through the function `mail-yank-original', and since superyank -overloads this function, cited yanking is automatically bound to the -C-c C-y key. There are three other smaller functions that are -provided with superyank and they are bound as below. Try C-h f on -each function to get more information on these functions. - -Key Bindings: - -C-c C-y mail-yank-original (superyank's version) -C-c q sy-fill-paragraph-manually -C-c C-q sy-fill-paragraph-manually -C-c i sy-insert-persist-attribution -C-c C-i sy-insert-persist-attribution -C-c C-o sy-open-line - - -Summary of variables, with their default values: - -sy-default-attribution (default: \"Anon\") - Attribution to use if no attribution string can be deciphered - from the original message buffer. - -sy-citation-string (default: \">\") - String to append to the attribution string for citation, for - best results, it should be one character with no trailing space. - -sy-nested-citation-p (default: nil) - Nil means use non-nested citations, non-nil means use old style - nested citations. - -sy-cite-regexp (default: \"[a-zA-Z0-9]*>\") - Regular expression that matches the beginning of a previously - cited line. Always used at the beginning of a line so it does - not need to start with a \"^\" character. - -sy-titlecue-regexp (default: \"\\s +-+\\s +\") - Regular expression that matches a title delimiter in the name - field. - -sy-preferred-attribution (default: 2) - Integer indicating user's preferred attribution field. - -sy-confirm-always-p (default: t) - Non-nil says always confirm with completion before inserting - attribution. - -sy-rewrite-header-hook (default: 'sy-header-on-said) - Hook for inserting informative header at the top of the yanked - message. - -sy-downcase-p (default: nil) - Non-nil says downcase the attribution string before insertion. - -sy-left-justify-p (default: nil) - Non-nil says delete leading white space before citing. - -sy-auto-fill-region-p (default: nil) - Non-nil says don't auto fill the region. T says auto fill the - paragraph. - -sy-use-only-preference-p (default: nil) - If nil, use backup scheme when preferred attribution string - can't be found. If non-nil and preferred attribution string - can't be found, then use sy-default-attribution." - - (interactive "P") - - (local-set-key "\C-cq" 'sy-fill-paragraph-manually) - (local-set-key "\C-c\C-q" 'sy-fill-paragraph-manually) - (local-set-key "\C-c\i" 'sy-insert-persist-attribution) - (local-set-key "\C-c\C-i" 'sy-insert-persist-attribution) - (local-set-key "\C-c\C-o" 'sy-open-line) - - (sy-yank-original arg)) - - -;; -;; ---------------------------------------------------------------------- -;; -;; based on Bruce Israel's "fill-paragraph-properly", and modified from -;; code posted by David C. Lawrence. Modified to use the persistant -;; attribution if none could be found from the paragraph. -;; -(defun sy-fill-paragraph-manually (arg) - "Fill paragraph containing or following point. -This automatically finds the sy-cite-regexp and uses it as the prefix. -If the sy-cite-regexp is not in the first line of the paragraph, it -makes a guess at what the fill-prefix for the paragraph should be by -looking at the first line and taking anything up to the first -alphanumeric character. - -Prefix arg means justify both sides of paragraph as well. - -This function just does fill-paragraph if the fill-prefix is set. If -what it deduces to be the paragraph prefix (based on the first line) -does not precede each line in the region, then the persistant -attribution is used. The persistant attribution is just the last -attribution string used to cite lines." - - (interactive "P") - (save-excursion - (forward-paragraph) - (or (bolp) - (newline 1)) - - (let ((end (point)) - st - (fill-prefix fill-prefix)) - (backward-paragraph) - (if (looking-at "\n") - (forward-char 1)) - (setq st (point)) - (if fill-prefix - nil - (untabify st end) ;; die, scurvy tabs! - ;; - ;; untabify might have made the paragraph longer character-wise, - ;; make sure end reflects the correct location of eop. - ;; - (forward-paragraph) - (setq end (point)) - (goto-char st) - (if (looking-at sy-cite-regexp) - (setq fill-prefix (concat - (buffer-substring - st (progn (re-search-forward sy-cite-regexp) - (point))) - " ")) - ;; - ;; this regexp is is convenient because paragraphs quoted by simple - ;; indentation must still yield to us <evil laugh> - ;; - (while (looking-at "[^a-zA-Z0-9]") - (forward-char 1)) - (setq fill-prefix (buffer-substring st (point)))) - (next-line 1) (beginning-of-line) - (while (and (< (point) end) - (not (string-equal fill-prefix ""))) - ;; - ;; if what we decided was the fill-prefix does not precede all - ;; of the lines in the paragraph, we probably goofed. In this - ;; case set it to the persistant attribution. - ;; - (if (looking-at (regexp-quote fill-prefix)) - () - (setq fill-prefix sy-persist-attribution)) - (next-line 1) - (beginning-of-line))) - (fill-region-as-paragraph st end arg)))) - -;; -;; ---------------------------------------------------------------------- -;; -;; insert the persistant attribution at point -;; -(defun sy-insert-persist-attribution () - "Insert the persistant attribution. -This inserts the peristant attribution at the beginning of the line that -point is on. This string is the last attribution confirmed and used -in the yanked reply buffer." - (interactive) - (save-excursion - (beginning-of-line) - (insert-string sy-persist-attribution))) - - -;; -;; ---------------------------------------------------------------------- -;; -;; open a line putting the attribution at the beginning - -(defun sy-open-line (arg) - "Insert a newline and leave point before it. -Also inserts the persistant attribution at the beginning of the line. -With argument, inserts ARG newlines." - (interactive "p") - (save-excursion - (let ((start (point))) - (open-line arg) - (goto-char start) - (forward-line) - (while (< 0 arg) - (sy-insert-persist-attribution) - (forward-line 1) - (setq arg (- arg 1)))))) - -(provide 'superyank) - -;;; superyank.el ends here
--- a/lisp/=term-nasty.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,12 +0,0 @@ -;;; term-nasty.el --- Damned Things from terminfo.el - -;;; This text is no longer included in Emacs, because it was censored -;;; by the Communications Decency Act. The law was promoted as a ban -;;; on pornography, but it bans far more than that. This file did not -;;; contain pornography, but it was prohibited nonetheless. - -;;; For information on US government censorship of the Internet, and -;;; what you can do to bring back freedom of the press, see the web -;;; site http://www.vtw.org/ - -;;; term-nasty.el ends here
--- a/lisp/=timer.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,223 +0,0 @@ -;;; timers.el --- run a function with args at some time in future - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Maintainer: FSF - -;; 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 package gives you the capability to run Emacs Lisp commands at -;; specified times in the future, either as one-shots or periodically. -;; The single entry point is `run-at-time'. - -;;; Code: - -;; Layout of a timer vector: -;; [triggered-p trigger-high trigger-low delta-secs function args] - -(defun timer-create () - "Create a timer object." - (let ((timer (make-vector 7 nil))) - (aset timer 0 (make-vector 1 'timer-event)) - timer)) - -(defun timerp (object) - "Return t if OBJECT is a timer." - (and (vectorp object) (= (length object) 7))) - -(defun timer-set-time (timer time &optional delta) - "Set the trigger time of TIMER to TIME. -TIME must be in the internal format returned by, e.g., `current-time' -If optional third argument DELTA is a non-zero integer make the timer -fire repeatedly that menu seconds apart." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 1 (car time)) - (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time))) - (aset timer 3 (if (consp (cdr time)) (nth 2 time) 0)) - (aset timer 4 (and (integerp delta) (> delta 0) delta)) - timer) - - -(defun timer-inc-time (timer secs &optional usecs) - "Increment the time set in TIMER by SECS seconds and USECS microseconds. -SECS may be a fraction." - (or usecs (setq usecs 0)) - (if (floatp secs) - (let* ((integer (floor secs)) - (fraction (floor (* 1000000 (- secs integer))))) - (setq usecs fraction secs integer))) - (let ((newusecs (+ (aref timer 3) usecs))) - (aset timer 3 (mod newusecs 1000000)) - (setq secs (+ secs (/ newusecs 1000000)))) - (let ((newlow (+ (aref timer 2) secs)) - (newhigh (aref timer 1))) - (setq newhigh (+ newhigh (/ newlow 65536)) - newlow (logand newlow 65535)) - (aset timer 1 newhigh) - (aset timer 2 newlow))) - -(defun timer-set-time-with-usecs (timer time usecs &optional delta) - "Set the trigger time of TIMER to TIME. -TIME must be in the internal format returned by, e.g., `current-time' -If optional third argument DELTA is a non-zero integer make the timer -fire repeatedly that menu seconds apart." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 1 (car time)) - (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time))) - (aset timer 3 usecs) - (aset timer 4 (and (integerp delta) (> delta 0) delta)) - timer) - -(defun timer-set-function (timer function &optional args) - "Make TIMER call FUNCTION with optional ARGS when triggering." - (or (timerp timer) - (error "Invalid timer")) - (aset timer 5 function) - (aset timer 6 args) - timer) - -(defun timer-activate (timer) - "Put TIMER on the list of active timers." - (if (and (timerp timer) - (integerp (aref timer 1)) - (integerp (aref timer 2)) - (integerp (aref timer 3)) - (aref timer 5)) - (let ((timers timer-list) - last) - ;; Skip all timers to trigger before the new one. - (while (and timers - (or (> (aref timer 1) (aref (car timers) 1)) - (and (= (aref timer 1) (aref (car timers) 1)) - (> (aref timer 2) (aref (car timers) 2))) - (and (= (aref timer 1) (aref (car timers) 1)) - (= (aref timer 2) (aref (car timers) 2)) - (> (aref timer 3) (aref (car timers) 3))))) - (setq last timers - timers (cdr timers))) - ;; Insert new timer after last which possibly means in front of queue. - (if last - (setcdr last (cons timer timers)) - (setq timer-list (cons timer timers))) - (aset timer 0 nil) - nil) - (error "Invalid or uninitialized timer"))) - -(defun cancel-timer (timer) - "Remove TIMER from the list of active timers." - (or (timerp timer) - (error "Invalid timer")) - (setq timer-list (delq timer timer-list)) - nil) - -(defun cancel-function-timers (function) - "Cancel all timers scheduled by `run-at-time' which would run FUNCTION." - (interactive "aCancel timers of function: ") - (let ((tail timer-list)) - (while tail - (if (eq (aref (car tail) 5) function) - (setq timer-list (delq (car tail) timer-list))) - (setq tail (cdr tail))))) - -;; Set up the common handler for all timer events. Since the event has -;; the timer as parameter we can still distinguish. Note that using -;; special-event-map ensures that event timer events that arrive in the -;; middle of a key sequence being entered are still handled correctly. -(define-key special-event-map [timer-event] 'timer-event-handler) -(defun timer-event-handler (event) - "Call the handler for the timer in the event EVENT." - (interactive "e") - (let ((timer (cdr-safe event))) - (if (timerp timer) - (progn - ;; Delete from queue. - (cancel-timer timer) - ;; Run handler - (apply (aref timer 5) (aref timer 6)) - ;; Re-schedule if requested. - (if (aref timer 4) - (progn - (timer-inc-time timer (aref timer 4) 0) - (timer-activate timer)))) - (error "Bogus timer event")))) - -;;;###autoload -(defun run-at-time (time repeat function &rest args) - "Run a function at a time, and optionally on a regular interval. -Arguments are TIME, REPEAT, FUNCTION &rest ARGS. -TIME is a string like \"11:23pm\" or a value from `encode-time'. -REPEAT, an integer number of seconds, is the interval on which to repeat -the call to the function. If REPEAT is nil or 0, call it just once." - (interactive "sRun at time: \nNRepeat interval: \naFunction: ") - - ;; Handle "11:23pm" and the like. Interpret it as meaning today - ;; which admittedly is rather stupid if we have passed that time - ;; already. Unfortunately we don't have a `parse-time' function - ;; to do the right thing. - (if (stringp time) - (progn - (require 'diary-lib) - (let ((hhmm (diary-entry-time time)) - (now (decode-time))) - (if (< hhmm 0) - (setq time 'bad) - (setq time - (encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now) - (nth 4 now) (nth 5 now) (nth 8 now))))))) - - ;; Special case: nil means "now" and is useful when repeting. - (if (null time) - (setq time (current-time))) - - (or (consp time) - (error "Invalid time format")) - - (or (null repeat) - (natnump repeat) - (error "Invalid repetition interval")) - - (let ((timer (timer-create))) - (timer-set-time timer time repeat) - (timer-set-function timer function args) - (timer-activate timer))) - -;;;###autoload -(defun run-after-delay (secs repeat function &rest args) - "Perform an action after a delay of SECS seconds. -Repeat the action every REPEAT seconds, if REPEAT is non-nil. -SECS and REPEAT need not be integers. -The action is to call FUNCTION with arguments ARGS." - (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ") - - (or (null repeat) - (and (numberp repeat) (>= repeat 0)) - (error "Invalid repetition interval")) - - (let ((timer (timer-create))) - (timer-set-time timer (current-time)) - (timer-inc-time timer secs) - (timer-set-function timer function args) - (timer-activate timer))) - -(provide 'timers) - -;;; timers.el ends here
--- a/lisp/=tpu-doc.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,469 +0,0 @@ -;;; tpu-doc.el --- Documentation for TPU-edt - -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Author: Rob Riepel <riepel@networking.stanford.edu> -;; Maintainer: Rob Riepel <riepel@networking.stanford.edu> -;; Keywords: emulations - -;; 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. - - -;; This is documentation for the TPU-edt editor for GNU emacs. Major -;; sections of this document are separated with lines that begin with -;; ";; %% <topic>", where <topic> is what is discussed in that section. - - -;; %% Contents - -;; % Introduction -;; % Terminal Support -;; % X-windows Support -;; % Differences Between TPU-edt and the Real Thing -;; % Starting TPU-edt -;; % TPU-edt Default Editing Keypad, Control and Gold Key Bindings -;; % Optional TPU-edt Extensions -;; % Customizing TPU-edt using the Emacs Initialization File -;; % Compiling TPU-edt -;; % Regular expressions in TPU-edt -;; % Etcetera - - -;; %% Introduction - -;; TPU-edt is based on tpu.el by Jeff Kowalski and Bob Covey. TPU-edt -;; endeavors to be even more like TPU's EDT emulation than the original -;; tpu.el. Considerable effort has been expended to that end. Still, -;; emacs is emacs and there are differences between TPU-edt and the -;; real thing. Please read the "Differences Between TPU-edt and the -;; Real Thing" and "Starting TPU-edt" sections before running TPU-edt. - - -;; %% Terminal Support - -;; TPU-edt, like it's VMS cousin, works on VT-series terminals with -;; DEC style keyboards. VT terminal emulators, including xterm with -;; the appropriate key translations, work just fine too. - - -;; %% X-windows Support - -;; Starting with version 19 of emacs, TPU-edt works with X-windows. -;; This is accomplished through a TPU-edt X keymap. The emacs lisp -;; program tpu-mapper.el creates this map and stores it in a file. -;; Tpu-mapper will be run automatically the first time you invoke -;; the X-windows version of emacs, or you can run it by hand. See -;; the commentary in tpu-mapper.el for details. - - -;; %% Differences Between TPU-edt and the Real Thing (not Coke (r)) - -;; Emacs (version 18.58) doesn't support text highlighting, so selected -;; regions are not shown in inverse video. Emacs uses the concept of -;; "the mark". The mark is set at one end of a selected region; the -;; cursor is at the other. The letter "M" appears in the mode line -;; when the mark is set. The native emacs command ^X^X (Control-X -;; twice) exchanges the cursor with the mark; this provides a handy -;; way to find the location of the mark. - -;; In TPU the cursor can be either bound or free. Bound means the -;; cursor cannot wander outside the text of the file being edited. -;; Free means the arrow keys can move the cursor past the ends of -;; lines. Free is the default mode in TPU; bound is the only mode -;; in EDT. Bound is the only mode in the base version of TPU-edt; -;; optional extensions add an approximation of free mode. - -;; Like TPU, emacs uses multiple buffers. Some buffers are used to -;; hold files you are editing; other "internal" buffers are used for -;; emacs' own purposes (like showing you help). Here are some commands -;; for dealing with buffers. - -;; Gold-B moves to next buffer, including internal buffers -;; Gold-N moves to next buffer containing a file -;; Gold-M brings up a buffer menu (like TPU "show buffers") - -;; Emacs is very fond of throwing up new windows. Dealing with all -;; these windows can be a little confusing at first, so here are a few -;; commands to that may help: - -;; Gold-Next_Scr moves to the next window on the screen -;; Gold-Prev_Scr moves to the previous window on the screen -;; Gold-TAB also moves to the next window on the screen - -;; Control-x 1 deletes all but the current window -;; Control-x 0 deletes the current window - -;; Note that the buffers associated with deleted windows still exist! - -;; Like TPU, TPU-edt has a "command" function, invoked with Gold-KP7 or -;; Do. Most of the commands available are emacs commands. Some TPU -;; commands are available, they are: replace, exit, quit, include, and -;; Get (unfortunately, "get" is an internal emacs function, so we are -;; stuck with "Get" - to make life easier, Get is available as Gold-g). - -;; Support for recall of commands, file names, and search strings was -;; added to emacs in version 19. For version 18 of emacs, optional -;; extensions are available to add this recall capability (see "Optional -;; TPU-edt Extensions" below). The history of strings recalled in both -;; versions of emacs differs slightly from TPU/edt, but it is still very -;; convenient. - -;; Help is available! The traditional help keys (Help and PF2) display -;; a three page help file showing the default keypad layout, control key -;; functions, and Gold key functions. Pressing any key inside of help -;; splits the screen and prints a description of the function of the -;; pressed key. Gold-PF2 invokes the native emacs help, with it's -;; zillions of options. Gold-Help shows all the current key bindings. - -;; Thanks to emacs, TPU-edt has some extensions that may make your life -;; easier, or at least more interesting. For example, Gold-r toggles -;; TPU-edt rectangular mode. In rectangular mode, Remove and Insert work -;; on rectangles. Likewise, Gold-* toggles TPU-edt regular expression -;; mode. In regular expression mode Find, Find Next, and the line-mode -;; replace command work with regular expressions. [A regular expression -;; is a pattern that denotes a set of strings; like VMS wildcards.] - -;; Emacs also gives TPU-edt the undo and occur functions. Undo does -;; what it says; it undoes the last change. Multiple undos in a row -;; undo multiple changes. For your convenience, undo is available on -;; Gold-u. Occur shows all the lines containing a specific string in -;; another window. Moving to that window, and typing ^C^C (Control-C -;; twice) on a particular line moves you back to the original window -;; at that line. Occur is on Gold-o. - -;; Finally, as you edit, remember that all the power of emacs is at -;; your disposal. It really is a fantastic tool. You may even want to -;; take some time and read the emacs tutorial; perhaps not to learn the -;; native emacs key bindings, but to get a feel for all the things -;; emacs can do for you. The emacs tutorial is available from the -;; emacs help function: "Gold-PF2 t" - - -;; %% Starting TPU-edt - -;; In order to use TPU-edt, the TPU-edt editor definitions, contained -;; in tpu-edt.el, need to be loaded when emacs is run. This can be -;; done in a couple of ways. The first is by explicitly requesting -;; loading of the TPU-edt emacs definition file on the command line: - -;; prompt> emacs -l /path/to/definitions/tpu-edt.el - -;; If TPU-edt is installed on your system, that is, if tpu-edt.el is in -;; a directory like /usr/local/emacs/lisp, along with dozens of other -;; .el files, you should be able to use the command: - -;; prompt> emacs -l tpu-edt - -;; If you like TPU-edt and want to use it all the time, you can load -;; the TPU-edt definitions using the emacs initialization file, .emacs. -;; Simply create a .emacs file in your home directory containing the -;; line: - -;; (load "/path/to/definitions/tpu-edt") - -;; or, if (as above) TPU-edt is installed on your system: - -;; (load "tpu-edt") - -;; Once TPU-edt has been loaded, you will be using an editor with the -;; interface shown in the next section (A section that is suitable for -;; cutting out of this document and pasting next to your terminal!). - - -;; %% TPU-edt Default Editing Keypad, Control and Gold Key Bindings -;; -;; _______________________ _______________________________ -;; | HELP | Do | | | | | | -;; |KeyDefs| | | | | | | -;; |_______|_______________| |_______|_______|_______|_______| -;; _______________________ _______________________________ -;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | -;; | | |Sto Tex| | key |E-Help | Find |Undel L| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Select |Pre Scr|Nex Scr| | Page | Sect |Append | Del W | -;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Move up| |Forward|Reverse|Remove | Del C | -;; | Top | |Bottom | Top |Insert |Undel C| -;; _______|_______|_______ |_______|_______|_______|_______| -;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | -;; |StaOfLi|Bottom |EndOfLi| |ChngCas|Del EOL|SpecIns| Enter | -;; |_______|_______|_______| |_______|_______|_______| | -;; | Line |Select | Subs | -;; | Open Line | Reset | | -;; |_______________|_______|_______| -;; Control Characters -;; -;; ^A toggle insert and overwrite ^L insert page break -;; ^B recall ^R remember, re-center -;; ^E end of line ^U delete to beginning of line -;; ^G cancel current operation ^V quote -;; ^H beginning of line ^W refresh -;; ^J delete previous word ^Z exit -;; ^K learn ^X^X exchange point and mark -;; -;; -;; Gold-<key> Functions -;; ----------------------------------------------------------------- -;; W Write - save current buffer -;; K Kill buffer - abandon edits and delete buffer -;; -;; E Exit - save current buffer and ask about others -;; X eXit - save all modified buffers and exit -;; Q Quit - exit without saving anything -;; -;; G Get - load a file into a new edit buffer -;; I Include - include a file in this buffer -;; -;; B next Buffer - display the next buffer (all buffers) -;; N Next file buffer - display next buffer containing a file -;; M buffer Menu - display a list of all buffers -;; -;; U Undo - undo the last edit -;; C Recall - edit and possibly repeat previous commands -;; -;; O Occur - show following lines containing REGEXP -;; S Search and substitute - line mode REPLACE command -;; -;; ? Spell check - check spelling in a region or entire buffer -;; -;; R Toggle Rectangular mode for remove and insert -;; * Toggle regular expression mode for search and substitute -;; -;; V Show TPU-edt version -;; ----------------------------------------------------------------- - - -;; %% Optional TPU-edt Extensions - -;; Several optional packages have been included in this distribution -;; of TPU-edt. The following is a brief description of each package. -;; See the {package}.el file for more detailed information and usage -;; instructions. - -;; tpu-extras - TPU/edt scroll margins and free cursor mode. -;; tpu-recall - String, file name, and command history. -;; vt-control - VTxxx terminal width and keypad controls. - -;; Packages are normally loaded from the emacs initialization file -;; (discussed below). If a package is not installed in the emacs -;; lisp directory, it can be loaded by specifying the complete path -;; to the package file. However, it is preferable to modify the -;; emacs load-path variable to include the directory where packages -;; are stored. This way, packages can be loaded by name, just as if -;; they were installed. The first part of the sample .emacs file -;; below shows how to make such a modification. - - -;; %% Customizing TPU-edt using the Emacs Initialization File - -;; .emacs - a sample emacs initialization file - -;; This is a sample emacs initialization file. It shows how to invoke -;; TPU-edt, and how to customize it. - -;; The load-path is where emacs looks for files to fulfill load requests. -;; If TPU-edt is not installed in a standard emacs directory, the load-path -;; should be updated to include the directory where the TPU-edt files are -;; stored. Modify and un-comment the following section if TPU-ed is not -;; installed on your system - be sure to leave the double quotes! - -;; (setq load-path -;; (append (list (expand-file-name "/path/to/tpu-edt/files")) -;; load-path)) - -;; Load TPU-edt -(load "tpu-edt") - -;; Load the optional goodies - scroll margins, free cursor mode, command -;; and string recall. But don't complain if the file aren't available. -(load "tpu-extras" t) -(load "tpu-recall" t) - -;; Uncomment this line to set scroll margins 10% (top) and 15% (bottom). -;(and (fboundp 'tpu-set-scroll-margins) (tpu-set-scroll-margins "10%" "15%")) - -;; Load the vtxxx terminal control functions, but don't complain if -;; if the file is not found. -(load "vt-control" t) - -;; TPU-edt treats words like EDT; here's how to add word separators. -;; Note that backslash (\) and double quote (") are quoted with '\'. -(tpu-add-word-separators "]\\[-_,.\"=+()'/*#:!&;$") - -;; Emacs is happy to save files without a final newline; other Unix programs -;; hate that! This line will make sure that files end with newlines. -(setq require-final-newline t) - -;; Emacs has the ability to automatically run code embedded in files -;; you edit. This line makes emacs ask if you want to run the code. -(if tpu-emacs19-p (setq enable-local-variables "ask") - (setq inhibit-local-variables t)) - -;; Emacs uses Control-s and Control-q. Problems can occur when using emacs -;; on terminals that use these codes for flow control (Xon/Xoff flow control). -;; These lines disable emacs' use of these characters. -(global-unset-key "\C-s") -(global-unset-key "\C-q") - -;; top, bottom, bol, eol seem like a waste of Gold-arrow functions. The -;; following section re-maps up and down arrow keys to top and bottom of -;; screen, and left and right arrow keys to pan left and right (pan-left, -;; right moves the screen 16 characters left or right - try it, you'll -;; like it!). - -;; Re-map the Gold-arrow functions -(define-key GOLD-CSI-map "A" 'tpu-beginning-of-window) ; up-arrow -(define-key GOLD-CSI-map "B" 'tpu-end-of-window) ; down-arrow -(define-key GOLD-CSI-map "C" 'tpu-pan-right) ; right-arrow -(define-key GOLD-CSI-map "D" 'tpu-pan-left) ; left-arrow -(define-key GOLD-SS3-map "A" 'tpu-beginning-of-window) ; up-arrow -(define-key GOLD-SS3-map "B" 'tpu-end-of-window) ; down-arrow -(define-key GOLD-SS3-map "C" 'tpu-pan-right) ; right-arrow -(define-key GOLD-SS3-map "D" 'tpu-pan-left) ; left-arrow - -;; Re-map the Gold-arrow functions for X-windows TPU-edt (emacs version 19) -(cond - ((and tpu-emacs19-p window-system) - (define-key GOLD-map [up] 'tpu-beginning-of-window) ; up-arrow - (define-key GOLD-map [down] 'tpu-end-of-window) ; down-arrow - (define-key GOLD-map [right] 'tpu-pan-right) ; right-arrow - (define-key GOLD-map [left] 'tpu-pan-left))) ; left-arrow - -;; The emacs universal-argument function is very useful for native emacs -;; commands. This line maps universal-argument to Gold-PF1 -(define-key GOLD-SS3-map "P" 'universal-argument) ; Gold-PF1 - -;; Make KP7 move by paragraphs, instead of pages. -(define-key SS3-map "w" 'tpu-paragraph) ; KP7 - -;; TPU-edt assumes you have the ispell spelling checker; -;; Un-comment this line if you don't. -;(setq tpu-have-spell nil) - -;; Display the TPU-edt version. -(tpu-version) - -;; End of .emacs - a sample emacs initialization file - -;; After initialization with the .emacs file shown above, the editing -;; keys have been re-mapped to look like this: - -;; _______________________ _______________________________ -;; | HELP | Do | | | | | | -;; |KeyDefs| | | | | | | -;; |_______|_______________| |_______|_______|_______|_______| -;; _______________________ _______________________________ -;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | -;; | | |Sto Tex| | U Arg |E-Help | Find |Undel L| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Select |Pre Scr|Nex Scr| |Paragra| Sect |Append | Del W | -;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Move up| |Forward|Reverse|Remove | Del C | -;; |Tscreen| |Bottom | Top |Insert |Undel C| -;; _______|_______|_______ |_______|_______|_______|_______| -;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | -;; |PanLeft|Bscreen|PanRigh| |ChngCas|Del EOL|SpecIns| Enter | -;; |_______|_______|_______| |_______|_______|_______| | -;; | Line |Select | Subs | -;; | Open Line | Reset | | -;; |_______________|_______|_______| - -;; Astute emacs hackers will realize that on systems where TPU-edt is -;; installed, this documentation file can be loaded to produce the above -;; editing keypad layout. In fact, to get all the changes in the sample -;; initialization file, you only need a one line initialization file: - -;; (load "tpu-doc") - -;; wow! - - -;; %% Compiling TPU-edt - -;; It is not necessary to compile (byte-compile in emacs parlance) -;; TPU-edt to use it. However, byte-compiled code loads and runs -;; faster, and takes up less memory when loaded. To byte compile -;; TPU-edt, use the following command. - -;; emacs -batch -f batch-byte-compile tpu-edt.el - -;; This will produce a file named tpu-edt.elc. This new file can be -;; used in place of the original tpu-edt.el file. In commands where -;; the file type is not specified, emacs always attempts to use the -;; byte-compiled version before resorting to the source. - - -;; %% Regular expressions in TPU-edt - -;; Gold-* toggles TPU-edt regular expression mode. In regular expression -;; mode, find, find next, replace, and substitute accept emacs regular -;; expressions. A complete list of emacs regular expressions can be -;; found using the emacs "info" command (it's somewhat like the VMS help -;; command). Try the following sequence of commands: - -;; DO info <enter info mode> -;; m regex <select the "regular expression" topic> -;; m directives <select the "directives" topic> - -;; Type "q" to quit out of info mode. - -;; There is a problem in regular expression mode when searching for -;; empty strings, like beginning-of-line (^) and end-of-line ($). -;; When searching for these strings, find-next may find the current -;; string, instead of the next one. This can cause global replace and -;; substitute commands to loop forever in the same location. For this -;; reason, commands like - -;; replace "^" "> " <add "> " to beginning of line> -;; replace "$" "00711" <add "00711" to end of line> - -;; may not work properly. - -;; Commands like those above are very useful for adding text to the -;; beginning or end of lines. They might work on a line-by-line basis, -;; but go into an infinite loop if the "all" response is specified. If -;; the goal is to add a string to the beginning or end of a particular -;; set of lines TPU-edt provides functions to do this. - -;; Gold-^ Add a string at BOL in region or buffer -;; Gold-$ Add a string at EOL in region or buffer - -;; There is also a TPU-edt interface to the native emacs string -;; replacement commands. Gold-/ invokes this command. It accepts -;; regular expressions if TPU-edt is in regular expression mode. Given -;; a repeat count, it will perform the replacement without prompting -;; for confirmation. - -;; This command replaces empty strings correctly, however, it has its -;; drawbacks. As a native emacs command, it has a different interface -;; than the emulated TPU commands. Also, it works only in the forward -;; direction, regardless of the current TPU-edt direction. - - -;; %% Etcetera - -;; That's TPU-edt in a nutshell... - -;; Please send any bug reports, feature requests, or cookies to the -;; author, Rob Riepel, at the address shown by the tpu-version command -;; (Gold-V). - -;; Share and enjoy... Rob Riepel 7/93 - -;;; tpu-doc.el ends here
--- a/lisp/=vmsx.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,144 +0,0 @@ -;;; vmsx.el --- run asynchronous VMS subprocesses under Emacs - -;; Copyright (C) 1986 Free Software Foundation, Inc. - -;; Author: Mukesh Prasad -;; Maintainer: FSF -;; Keywords: vms - -;; 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. - -;;; Code: - -(defvar display-subprocess-window nil - "If non-nil, the suprocess window is displayed whenever input is received.") - -(defvar command-prefix-string "$ " - "String to insert to distinguish commands entered by user.") - -(defvar subprocess-running nil) -(defvar command-mode-map nil) - -(if command-mode-map - nil - (setq command-mode-map (make-sparse-keymap)) - (define-key command-mode-map "\C-m" 'command-send-input) - (define-key command-mode-map "\C-u" 'command-kill-line)) - -(defun subprocess-input (name str) - "Handles input from a subprocess. Called by Emacs." - (if display-subprocess-window - (display-buffer subprocess-buf)) - (let ((old-buffer (current-buffer))) - (set-buffer subprocess-buf) - (goto-char (point-max)) - (insert str) - (insert ?\n) - (set-buffer old-buffer))) - -(defun subprocess-exit (name) - "Called by Emacs upon subprocess exit." - (setq subprocess-running nil)) - -(defun start-subprocess () - "Spawns an asynchronous subprocess with output redirected to -the buffer *COMMAND*. Within this buffer, use C-m to send -the last line to the subprocess or to bring another line to -the end." - (if subprocess-running - (return t)) - (setq subprocess-buf (get-buffer-create "*COMMAND*")) - (save-excursion - (set-buffer subprocess-buf) - (use-local-map command-mode-map)) - (setq subprocess-running (spawn-subprocess 1 'subprocess-input - 'subprocess-exit)) - ;; Initialize subprocess so it doesn't panic and die upon - ;; encountering the first error. - (and subprocess-running - (send-command-to-subprocess 1 "ON SEVERE_ERROR THEN CONTINUE"))) - -(defvar subprocess-command-to-buffer-tmpdir "SYS$SCRATCH:" - "*Put temporary files from subprocess-command-to-buffer here.") - -(defun subprocess-command-to-buffer (command buffer) - "Execute command and redirect output into buffer. - -BUGS: only the output up to the end of the first image activation is trapped." - (if (not subprocess-running) - (start-subprocess)) - (save-excursion - (set-buffer buffer) - (let ((output-filename - (concat subprocess-command-to-buffer-tmpdir - "OUTPUT-FOR-" (getenv "USER") ".LISTING"))) - (while (file-attributes output-filename) - (delete-file output-filename)) - (send-command-to-subprocess 1 (concat "DEFINE/USER SYS$OUTPUT " - output-filename "-NEW")) - (send-command-to-subprocess 1 command) - (send-command-to-subprocess 1 (concat "RENAME " output-filename - "-NEW " output-filename)) - (while (not (file-attributes output-filename)) - (sleep-for 2)) - (insert-file output-filename)))) - -(defun subprocess-command () - "Starts asynchronous subprocess if not running and switches to its window." - (interactive) - (if (not subprocess-running) - (start-subprocess)) - (and subprocess-running - (progn (pop-to-buffer subprocess-buf) (goto-char (point-max))))) - -(defun command-send-input () - "If at last line of buffer, sends the current line to -the spawned subprocess. Otherwise brings back current -line to the last line for resubmission." - (interactive) - (beginning-of-line) - (let ((current-line (buffer-substring (point) - (progn (end-of-line) (point))))) - (if (eobp) - (progn - (if (not subprocess-running) - (start-subprocess)) - (if subprocess-running - (progn - (beginning-of-line) - (send-command-to-subprocess 1 current-line) - (if command-prefix-string - (progn (beginning-of-line) (insert command-prefix-string))) - (next-line 1)))) - ;; else -- if not at last line in buffer - (end-of-buffer) - (backward-char) - (next-line 1) - (if (string-equal command-prefix-string - (substring current-line 0 (length command-prefix-string))) - (insert (substring current-line (length command-prefix-string))) - (insert current-line))))) - -(defun command-kill-line() - "Kills the current line. Used in command mode." - (interactive) - (beginning-of-line) - (kill-line)) - -(define-key esc-map "$" 'subprocess-command) - -;;; vmsx.el ends here
--- a/lisp/=word-help.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,970 +0,0 @@ -;;; word-help.el --- keyword help for any language doc'd in TeXinfo. - -;; Copyright (c) 1996 Free Software Foundation, Inc. - -;; Author: Jens T. Berger Thielemann <jensthi@ifi.uio.no> -;; Keywords: help, keyword, languages, completion - -;; This file is part of GNU Emacs. - -;; 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, 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; 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 package provides a rather general interface for doing keyword -;; help in most languages. In short, it'll determine which TeXinfo -;; file which is relevant for the current mode; cache the index and -;; use regexps to give you help on the keyword you're looking at. - -;; Installation -;; ************ - -;; For the default setup to work for all supported modes, make sure -;; the Texinfo files from the following packages are installed: - -;; Texinfo file | Available in archive or URL | Notes -;; autoconf.info | autoconf-2.10.tar.gz | - -;; bison.info | bison-1.25.tar.gz | - -;; libc.info | glibc-1.09.1.tar.gz | - -;; elisp.info | elisp-manual-19-2.4.tar.gz | - -;; latex.info | ftp://ftp.dante.de/pub/tex/info/latex2e-help-texinfo/latex2e.texi -;; groff.info | groff-1.10.tar.gz | - -;; m4.info | m4-1.4.tar.gz | - -;; make.info | make-3.75.tar.gz | - -;; perl.info | http://www.perl.com/CPAN/doc/manual/info/ -;; simula.info | Mail bjort@ifi.uio.no | Written in Norwegian -;; texinfo.info | texinfo-3.9.tar.gz | - - -;; BTW: We refer to Texinfo files by just their last component, not -;; with an absolute file name. You must thus set up -;; `Info-directory-list' and `Info-default-directory-list' so that -;; these can automatically be located. - -;; Usage -;; ***** -;; -;; Place the cursor over the function/variable/type/whatever you want -;; help on. Type "C-h C-i". `word-help' will then make a suggestion -;; to an index topic; press return to accept this. If not, you may use -;; tab-completion to find the topic you're interested in. - -;; `word-help' is also able to do symbol completion via the -;; `word-help-complete' function. Bind this function to C-TAB by -;; adding the following line to your .emacs file: -;; -;; (global-set-key [?\M-\t] 'word-help-complete) -;; -;; Note that some modes automatically override this key; you may -;; therefore wish to either put the above statement in a hook or -;; associate the function with an other key. - -;; Usually, `word-help' is able to determine the relevant Texinfo -;; file from looking at the buffer's `mode-name'; if not, you can use -;; the interactive function `set-help-file' to set this. - -;; Customizing -;; *********** -;; -;; User interface -;; -------------- -;; -;; Two variables control the behaviour of the user-interface of -;; `word-help': `word-help-split-window' and -;; `word-help-magic-index'. Do C-h v to get more information on -;; these. - -;; Adding more Texinfo files -;; ------------------------- -;; -;; Associations between mode-names and Texinfo files can be done -;; through the `word-help-mode-alist' variable, which defines an -;; `alist' making `set-help-file' able to initialize the necessary -;; variable. - -;; NOTE: If you have to customize the regexps, it is *CRUCIAL* that -;; none of your regexps match the empty string! Not adhering to this -;; restriction will make `word-help' enter an infinite loop. - -;; Contacting the author -;; ********************* -;; -;; If you wish to contact me for any reason, please feel free to write -;; to: - -;; Jens Berger -;; Spektrumveien 4 -;; N-0666 Oslo -;; Norway -;; -;; E-mail: <jensthi@ifi.uio.no> - -;; Have fun. - -;; -;;; Code: -;; - -(require 'info) - -;;;-------------------- -;;; USER OPTIONS -;;;-------------------- - -(defvar word-help-split-window t - "*Non-nil means that the info buffer will pop up in a separate window. -If nil, we will just switch to it.") - -(defvar word-help-magic-index t - "*Non-nil means that the keyword will be searched for in the requested node. -This is done by determining whether the line the point is positioned -on after using `Info-goto-node', actually contains the keyword. If -not, we will search for the first occurence of the keyword. This may -help when the info file isn't correctly indexed.") - -;;; ---- end of user configurable variables - -;;;------------------------- -;;; ADVANCED USER OPTIONS -;;;------------------------- - -(defvar word-help-mode-alist - '( - ("autoconf" - (("autoconf" "Macro Index") ("m4" "Macro index")) - (("AC_\\([A-Za-z0-9_]+\\)" 1) - ("[a-z]+")) - nil - nil - (("AC_\\([A-Za-z0-9_]+\\)" 1 nil (("^[A-Z_]+$"))) - ("[a-z_][a-z_]*" 0 nil (("^[a-z_]+$"))))) - - ("Bison" - (("bison" "Index") - ("libc" "Type Index" "Function Index" "Variable Index")) - (("%[A-Za-z]*") - ("[A-Za-z_][A-Za-z0-9_]*")) - nil - nil - (("%[A-Za-z]*" nil nil (("^%"))) - ("[A-Za-z_][A-Za-z0-9_]*" nil nil (("[A-Za-z_][A-Za-z0-9_]*"))))) - - ("YACC" . "Bison") - - ("C" (("libc" "Type Index" "Function Index" "Variable Index"))) - ("C++" . "C") - - ("Emacs-Lisp" - (("elisp" "Index")) - (("[^][ ()\n\t.\"'#]+")) - nil - nil - lisp-complete-symbol) - - ("LaTeX" - (("latex" "Command Index")) - (("\\\\\\(begin\\|end\\){\\([^}\n]+\\)}" 2 0) - ("\\\\[A-Za-z]+") - ("\\\\[^A-Za-z]") - ("[A-Za-z]+")) - nil - nil - (("\\\\begin{\\([A-Za-z]*\\)" 1 "}" (("^[A-Za-z]+$"))) - ("\\\\end{\\([A-Za-z]*\\)" 1 "}" (("^[A-Za-z]+$"))) - ("\\\\renewcommand{\\(\\\\?[A-Za-z]*\\)" 1 "}" (("^\\\\[A-Za-z]+"))) - ("\\\\renewcommand\\(\\\\?[A-Za-z]*\\)" 1 "" (("^\\\\[A-Za-z]+"))) - ("\\\\renewenvironment{?\\([A-Za-z]*\\)" 1 "}"(("^[A-Za-z]+$"))) - ("\\\\[A-Za-z]*" 0 "" (("^\\\\[A-Za-z]+"))))) - - ("latex" . "LaTeX") - - ("Nroff" - (("groff" "Macro Index" "Register Index" "Request Index")) - (("\\.[^A-Za-z]") - ("\\.[A-Za-z]+") - ("\\.\\([A-Za-z]+\\)" 1)) - nil - nil - (("\\.[A-Za-z]*" nil nil (("^\\.[A-Za-z]+$"))) - ("\\.\\([A-Za-z]*\\)" 1 nil (("^[A-Za-z]+$"))))) - - ("Groff" . "Nroff") - - ("m4" - (("m4" "Macro index")) - (("\\([mM]4_\\)?\\([A-Za-z_][A-Za-z_0-9]*\\)" 2)) - nil - nil - (("[mM]4_\\([A-Za-z_]?[A-Za-z_0-9]*\\)" 1) - ("[A-Za-z_][A-Za-z_0-9]*"))) - - ("Makefile" - (("make" "Name Index")) - (("\\.[A-Za-z]+") ;; .SUFFIXES - ("\\$[^()]") ;; $@ - ("\\$([^A-Za-z].)") ;; $(<@) - ("\\$[\(\{]\\([a-zA-Z+]\\)" 1) ;; $(wildcard) - ("[A-Za-z]+")) ;; foreach - nil - nil - (("\\.[A-Za-z]*" nil ":" (("^\\.[A-Za-z]+$"))) - ("\\$(\\([A-Z]*\\)" 1 ")" (("^[A-Z]"))) - ("[a-z]+" nil nil (("^[a-z]+$"))))) - - ("Perl" - (("perl" "Variable Index" "Function Index")) - (("\\$[^A-Za-z^]") ;; $@ - ("\\$\\^[A-Za-z]?") ;; $^D - ("\\$[A-Za-z][A-Za-z_0-9]+") ;; $foobar - ("[A-Za-z_][A-Za-z_0-9]+")) ;; dbmopen - nil - nil - (("\\$[A-Za-z]*" nil nil (("^\\$[A-Za-z]+$"))) ;; $variable - ("[A-Za-z_][A-Za-z_0-9]*" nil nil - (("^[A-Za-z_][A-Za-z_0-9]*$"))))) ;; function - - ("Simula" (("simula" "Index")) nil t) - ("Ifi Simula" . "Simula") - ("SIMULA" . "Simula") - - ("Texinfo" - (("texinfo" "Command and Variable Index")) - (("@\\([A-Za-z]+\\)" 1)) - nil - nil - (("@\\([A-Za-z]*\\)" 1))) - - ) - "Assoc list between `mode-name' and Texinfo files. -The variable should be initialized with a list of elements with the -following form: - -\(mode-name (word-help-info-files) (word-help-keyword-regexps) - word-help-ignore-case word-help-index-mapper - word-help-complete-list) - -where `word-help-info-files', `word-help-keyword-regexps' and so -forth of course are the values which should be put in these variables -for this mode. Note that `mode-name' doesn't have to be a legal -mode-name; the user may use the call `set-help-file', where -`mode-name' will be used in the `completing-read'. - -Example entry (for C): - -\(\"C\" ((\"libc\" \"Type Index\" \"Function Index\" \"Variable Index\")) - ((\"[A-Za-z_][A-Za-z0-9]+\"))) - -The two first variables must be initialized; the two remaining will -get default values if you omit them or set them to nil. The default -values are: - -word-help-keyword-regexps: (\"[A-Za-z_][A-Za-z0-9]+\") -word-help-ignore-case: nil - -More settings may be defined in the future. - -You may also define aliases, if there are several relevant mode-names -to a single entry. These should be of the form: - -\(MODE-NAME-ALIAS . MODE-NAME-REAL) - -For C++, you would use the alias - -\(\"C++\" . \"C\") - -to make C++ mode use the same help files as C files do. Please note -that you can shoot yourself in the foot with this possibility, by -defining recursive aliases.") - -;;; --- end of advanced user options - -(defvar word-help-ignore-case nil - "Non-nil means that case is ignored when doing lookup.") -(make-variable-buffer-local 'word-help-ignore-case) - -(defvar word-help-info-files nil - "List of info files with respective nodes, for the current mode. - -This should be a list of the following form: - -\((INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...) - (INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...) - : : : - (INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...)) - -An example entry for e.g. C would be: - -\((\"/local/share/gnu/info/libc\" \"Function Index\" \"Type Index\" - \"Variable Index\")) - -The files and nodes will be searched/cached in the order specified. -This variable is usually set by the `word-help-switch-help-file' -function, which utilizes the `word-help-mode-alist'.") -(make-variable-buffer-local 'word-help-info-files) - -(defvar word-help-keyword-regexps nil - "Regexps for finding keywords in the current mode. - -This is constructed as a list of the following form: - -\((REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR) - (REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR) - : : : - (REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR)) - -The regexps will be searched in order for a match which the cursor is -within. - -submatch-lookup is the submatch number which will be looked for in the -index. May be omitted; defaults to 0 (e.g. the entire pattern). This is -useful in for instance configure lookup; each command is there prefixed -with 'AC_', which must be ignored when doing a lookup. Example regexp -entry for this: - -\(\"AC_\\\\([A-Za-z0-9]+\\\\)\" 1) - -submatch-cursor is the part of the match which the cursor must be within. -May be omitted; defaults to 0 (e.g. the entire pattern).") -(make-variable-buffer-local 'word-help-keyword-regexps) -(set-default 'word-help-keyword-regexps '(("[A-Za-z_][A-Za-z_0-9]*"))) - -(defvar word-help-index-mapper nil - "Regexps to use for massaging index-entries into keywords. -This variable should contain a list of regexps with sub-expressions, -where we will only look for the sub-expression in the user text. - -The regexp list should be formatted as: - - ((REGEXP SUBEXP) (REGEXP SUBEXP) ... ) - -If the index entry does not match any of the regexps, it will be ignored. - -Example: - -Perl has index entries of the following form: - -* abs VALUE: perlfunc. -* accept NEWSOCKET,GENERICSOCKET: perlfunc. -* alarm SECONDS: perlfunc. -* atan2 Y,X: perlfunc. -* bind SOCKET,NAME: perlfunc. - : : : - -We will thus try to extract the first word in the index entry - -\"abs\" from \"abs VALUE\", etc. This is done by the following entry: - -\((\"^\\\\([^ \\t\\n]+\\\\)\" 1)) - -This value is btw. the default one, and works with most Texinfo files") -(make-variable-buffer-local 'word-help-index-mapper) -(set-default 'word-help-index-mapper '(("^\\([^ \t\n]+\\)" 1))) - - -(defvar word-help-complete-list nil - "Regexps or function to use for completion of symbols. -The list should have the following format: - - ((REGEXP SUBMATCH TEXT-APPEND (RE-FILTER-1 REG-FILTER-2 ...) - : : : : : - (REGEXP SUBMATCH TEXT-APPEND (RE-FILTER-1 REG-FILTER-2 ...)) - -The two first entries are similar to `word-help-keyword-regexps', -REGEXP is a regular expression which should match any relevant -expression, and where SUBMATCH should be used for look up. By -specifying non-nil REGEXP-FILTERs, we'll only include entries in the -index which matches the regexp specified. - -If the contents of this variable is a symbol of a function, this -function will be called instead. This is useful for modes providing -a more intelligent function (like `lisp-complete-symbol' in Emacs Lisp mode). - -If you would like to use another function instead, you may. - -Non-nil TEXT-APPEND means that this text will be inserted after the -completion, if we manage to do make a completion.") -(make-variable-buffer-local 'word-help-complete-list) -(set-default 'word-help-complete-list '(("[A-Za-z_][A-Za-z_0-9]*"))) - -;;; Work variables - - -(defvar word-help-main-index nil - "List of all index entries. - -See `word-help-process-indexes' for structure formatting. - -Minor note: This variable is a list if it is initialized, t if -initializing failed and nil if uninitialized.") -(make-variable-buffer-local 'word-help-main-index) - -(defvar word-help-complete-index nil - "List of regexps for completion, with matching index entries. -Value is nil if uninitialized, t if initialized but not accessible, -a list if we're feeling ok.") -(make-variable-buffer-local 'word-help-complete-index) - -(defvar word-help-main-obarray nil - "Global work variable for `word-help' system. -Do Not mess with this!") - -(defvar word-help-history nil - "History for `word-help' minibuffer queries.") -(make-local-variable 'word-help-history) - -(defvar word-help-current-help-file nil - "Current help file active for this mode.") - -(defvar word-help-index-alist nil - "An assoc list mapping help files to info indexes. -This means that `word-help-mode-index' can be init'ed faster.") - -(defvar word-help-help-mode nil - "Which mode the help system is bound to for the current mode.") -(make-variable-buffer-local 'word-help-help-mode) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;; User Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Debugging - -;;;###autoload -(defun reset-word-help () - "Clear all cached indexes in the `word-help' system. -You should only need this when installing new info files, and/or -adding more Texinfo files to the `word-help' system." - (interactive) - (setq word-help-index-alist nil - word-help-main-index nil - word-help-info-files nil - word-help-complete-index nil)) - - -;;; Changing help file - -;;;###autoload -(defun set-word-help-file () - "Change which set of Texinfo files used for word-help. - -`word-help' maintains a list over which Texinfo files which are -relevant for each programming language (`word-help-mode-alist'). It -usually selects the correct one, based upon the value of `mode-name'. -If this guess is incorrect, you may also use this function manually to -instruct future `word-help' calls which Texinfo files to use." - (interactive) - (let (helpfile helpguess (completion-ignore-case t)) -;; Try to make a guess - (setq helpguess (cond - (word-help-current-help-file) - ((word-help-guess-help-file)))) -;; Ask the user - (setq helpfile (completing-read - (if helpguess - (format "Select help mode (default %s): " helpguess) - "Select help mode: ") - word-help-mode-alist - nil t nil nil)) - (if (equal "" helpfile) - (setq helpfile helpguess)) - (if helpfile - (word-help-switch-help-file helpfile)))) - -;;; Main user interface - -;;;###autoload -(defun word-help () - "Find documentation on the keyword under the cursor. -The determination of which language the keyword belongs to, is based upon -The relevant info file is selected by matching `mode-name' (the major -mode) against the assoc list `word-help-mode-alist'. - -If this is not possible, `set-help-file' will be invoked for selecting -the relevant info file. `set-help-file' may also be invoked -interactively by the user. - -If the keyword you are looking at is not available in any index, no -default suggestion will be presented. " - (interactive) - (let (myguess guess index-info - (completion-ignore-case word-help-ignore-case)) -;; Set necessary variables for later lookup - (word-help-find-help-file) -;; Have we previously cached datas? - (word-help-process-indexes) - (if - (atom word-help-main-index) - (message "No help file available for this mode.") -;; First make a guess at what the user is looking for - (setq myguess (word-help-guess - (point) - (cond - ((not (atom word-help-main-index)) - (car word-help-main-index))) - word-help-keyword-regexps)) -;; Ask the user himself - (setq guess (completing-read - ; Format string - (if myguess - (format "Look up keyword (default %s): " myguess) - "Look up keyword: ") - ; Collection - (car word-help-main-index) - nil t nil 'word-help-history)) - (if (equal guess "") - (setq guess myguess)) -;; If we've got anything meaningful to lookup, do so - (if (not guess) - (message "Help aborted.") - (setq index-info (word-help-find-index-node - guess - word-help-main-index)) - (if (not index-info) - (message "Oops, I could not find \"%s\" anyway! Bug?" guess) - (word-help-goto-index-node (nconc index-info (list guess)))))))) - -;;;###autoload -(defun word-help-complete () - "Perform completion on the symbol preceding the point. -The determination of which language the keyword belongs to, is based upon -The relevant info file is selected by matching `mode-name' (the major -mode) against the assoc list `word-help-mode-alist'. - -If this is not possible, `set-help-file' will be invoked for selecting -the relevant info file. `set-help-file' may also be invoked -interactively by the user. - -The keywords are extracted from the index of the info file defined for -this mode, by using the `word-help-complete-list' variable." - (interactive) - (word-help-make-complete) - (cond - ((not word-help-complete-index) - (message "No completion available for this mode.")) - ((symbolp word-help-complete-index) - (call-interactively word-help-complete-index)) - ((listp word-help-complete-index) - (let ((all-match (word-help-guess-all (point) - word-help-complete-index t)) - (completion-ignore-case word-help-ignore-case) - (c-list word-help-complete-index) - c-entry word-match completion completed) -;; Loop over and try to find a match - (while (and all-match (not completed)) - (setq word-match (car all-match) - c-entry (car c-list) - c-list (cdr c-list) - all-match (cdr all-match)) -;; Check whether the current pattern matched - (if word-match - (let ((close (nth 3 c-entry)) - (words (nth 4 c-entry))) -;; Find the maximum completion for this word -; (print word-match) -; (print c-entry) -; (print close) - (setq completion (try-completion word-match words)) -;; Was the match exact - (cond ((eq completion t) - (and close - (not (looking-at (regexp-quote close))) - (insert close)) - (setq completed t)) -;; Silently ignore non-matches - ((not completion)) -;; May we complete more unambiguously - ((not (string-equal completion word-match)) - (delete-region (- (point) (length word-match)) - (point)) - (insert completion) - (if (eq t (try-completion completion words)) - (progn - (and close - (not (looking-at (regexp-quote close))) - (insert close)))) - (setq completed t)) - (t - (message "Making completion list...") - (let ((list (all-completions word-match words nil))) - (setq completed list) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list list))) - (message "Making completion list...done")))))) - (if (not completed) (message "No match.")))) - (t (message "No completion available for this mode.")))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;; Index mapping ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defun word-help-map-index-entries (str re-list) - "Transform an Info index entry into a programming keyword. -Uses this by mapping the entries through `word-help-index-mapper'." - (let ((regexp (car (car re-list))) - (subexp (car (cdr (car re-list)))) - (next (cdr re-list))) - (cond - ((string-match regexp str) - (substring str (match-beginning subexp) (match-end subexp))) - (next - (word-help-map-index-entries str next))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;; Switch mode files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Mode lookup - -(defun word-help-guess-help-file () - "Guesses a relevant help file based on mode name. -Returns nil if no guess could be made. Uses `word-help-mode-alist'." - (let (guess) - (cond - ((setq guess (assoc mode-name word-help-mode-alist)) - (car guess))))) - - -(defun word-help-switch-help-file (helpfile) - "Changes the help-file to the mode name given. -Uses `word-help-mode-alist'." - (if helpfile - (let (helpdesc) - (if (not (setq helpdesc (assoc helpfile word-help-mode-alist))) - (message "No help defined for \"%s\"." helpfile) - (if (stringp (cdr helpdesc)) - (word-help-switch-help-file (cdr helpdesc)) - (word-help-make-default-map - helpdesc - (list 'word-help-help-mode - 'word-help-info-files - 'word-help-keyword-regexps - 'word-help-ignore-case - 'word-help-index-mapper - 'word-help-complete-list)))) - (setq word-help-main-index nil - word-help-complete-index nil)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;; Index collection ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defun word-help-extract-index (file-name index-list index-map ignore-case) - "Extract index from filename and the first node name in index list. -`file-name' is the name of the info file, while `index-list' is a list -of node-names to search." - (let (cmd1 cmdlow nodename ob-array next (case-fold-search word-help-ignore-case)) - (setq nodename (car index-list)) - (setq ob-array (make-vector 211 0)) - (message "Processing \"%s\" in %s..." nodename file-name) - (save-window-excursion - (Info-goto-node (concat "(" file-name ")" nodename)) - (end-of-buffer) - (while (re-search-backward "\\* \\([^\n:]+\\):" nil t) - (setq cmd1 (buffer-substring (match-beginning 1) (match-end 1))) - (setq cmdlow (if ignore-case (downcase cmd1) cmd1)) - (if index-map - (setq cmdlow (word-help-map-index-entries cmdlow - index-map))) -;; We have to do this workaround to support case-insensitive matching - (cond - (cmdlow - (put (intern cmdlow ob-array) 'word-help-real-name cmd1) - (intern cmdlow word-help-main-obarray))))) - (setq next (cond - ((cdr index-list) - (word-help-extract-index file-name (cdr index-list) - index-map ignore-case)))) - (nconc (list (list nodename ob-array)) next))) - - -(defun word-help-collect-indexes (info-file) - "Process all the indexes in an info file. - -Uses `word-help-extract-index' on each node, and returns an entry -suitable for merging into `word-help-process-indexes'. `info-file' -is an entry of the form - -\(FILE-NAME INDEX-NAME-1 INDEX-NAME-2 ...)" - (let ((file (car info-file)) - (nodes (cdr info-file))) - (nconc (list file) (word-help-extract-index file nodes - word-help-index-mapper - word-help-ignore-case)))) - -(defun word-help-process-indexes () - "Process all the entries in the global variable `word-help-info-files'. -Returns a list formatted as follows: - -\(all-entries-ob - (file-name-1 (node-name-1 this-node-entries-ob) - (node-name-2 this-node-entries-ob) - : : : - (node-name-n this-node-entries-ob)) - (file-name-2 (node-name-1 this-node-entries-ob) - (node-name-2 this-node-entries-ob) - : : : - (node-name-n this-node-entries-ob)) - : : : : : : : : : - (file-name-n (node-name-1 this-node-entries-ob) - (node-name-2 this-node-entries-ob) - : : : - (node-name-n this-node-entries-ob))) - -The symbols in the obarrays may contain the additional property -`word-help-real-name', which tells the *real* node to go to. - -Note that we use `word-help-index-alist' to speed up the process. Note -that `word-help-switch-help-file' must have been called before this function. - -This structure is then later searched by `word-help-find-index-node'." - (let (index-words old-index) - (if (not word-help-main-index) - (cond - ((setq old-index - (assoc word-help-help-mode word-help-index-alist)) - (setq word-help-main-index (nth 1 old-index))) - (word-help-info-files - (setq word-help-main-obarray (make-vector 307 0) - index-words (mapcar 'word-help-collect-indexes - word-help-info-files) - word-help-main-index - (append (list word-help-main-obarray) index-words)) - (setq word-help-index-alist (cons (list word-help-help-mode - word-help-main-index) - word-help-index-alist))) - (t (setq word-help-main-index t)))))) - -(defun word-help-find-help-file () - "Tries to find and set a relevant help file for the current mode." - (let (helpguess) - (if (not word-help-info-files) - (if (setq helpguess (word-help-guess-help-file)) - (word-help-switch-help-file helpguess) - (set-help-file))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;; Keyword guess ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun word-help-guess-all (cur-point re-list - &optional copy-to-point) - "Guesses *all* keywords the user possibly may be looking at. -Returns a list of all possible keywords. " - (let ((regexp (car (car re-list))) - (submatch (cond ((nth 1 (car re-list))) (0))) - (cursmatch (cond ((nth 2 (car re-list))) (0))) - (guess nil) - (next-guess nil) - (case-fold-search word-help-ignore-case) - (end-point nil)) - (save-excursion - (end-of-line) - (setq end-point (point)) - ;; Start at the beginning - (beginning-of-line) - (while (and (not guess) (re-search-forward regexp end-point t)) - ;; Look whether the cursor is within the match - (if (and (<= (match-beginning cursmatch) cur-point) - (>= (match-end cursmatch) cur-point)) - (if (or (not copy-to-point) (<= cur-point (match-end submatch))) - (setq guess (buffer-substring (match-beginning submatch) - (if copy-to-point - cur-point - (match-end submatch))))))) - ;; If we found anything, return it and call ourselves again - (if (cdr re-list) - (setq next-guess (word-help-guess-all cur-point (cdr re-list) - copy-to-point)))) - (cons guess next-guess))) - -(defun word-help-guess-match (all-match cmd-array) - (let ((sym (car all-match))) - (cond - ((and sym (intern-soft (if word-help-ignore-case - (downcase sym) - sym) cmd-array) - sym)) - ((cdr all-match) - (word-help-guess-match (cdr all-match) cmd-array))))) - - -(defun word-help-guess (cur-point cmd-array re-list) - "Guesses what keyword the user is looking at, and returns that. -CUR-POINT should be the current value of `point', CMD-ARRAY an obarray -of all the keywords which are defined for the current mode, and -RE-LIST a list of regexps use for the hunt. See also -`word-help-keyword-regexps'." - (let ((all-matches (word-help-guess-all cur-point re-list))) -; (print all-matches) - (word-help-guess-match all-matches cmd-array))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;; Show node for keyword ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Find an index entry - -(defun word-help-find-index-node (node index-reg) - "Finds the node named `node' in the index-register `index-reg'. -`index-reg' has the format as returned (and documented) by the -`word-help-process-indexes' call. In most cases, this will be equal to -`word-help-main-index'. - -Returns a list with format - (file-name index-node-name index-entry) -which contains the file and index where the entry can be found. -Returns nil if the entry can't be found." - (let (file-info node-name) - (setq node-name (cond (word-help-ignore-case (downcase node)) (node))) - (if (intern-soft node-name (car index-reg)) - (setq file-info (word-help-index-search-file node-name - (cdr index-reg)))) - file-info)) - -(defun word-help-index-search-file (entry file-data) - "Searches a cached file for the index-entry `entry'." - (let (this-file next-files file-name node node-infos) - (setq this-file (car file-data) - next-files (cdr file-data) - file-name (car this-file) - node-infos (cdr this-file) - node (word-help-index-search-nodes entry node-infos)) - (cond - (node - (cons file-name node)) - (next-files (word-help-index-search-file entry next-files))))) - -(defun word-help-index-search-nodes (entry node-info) - "Searches a cached list of nodes for the entry `entry'." - (let (this-node next-nodes node-name node-ob node-sym) - (setq this-node (car node-info) - next-nodes (cdr node-info) - node-name (car this-node) - node-ob (car (cdr this-node)) - node-sym (intern-soft entry node-ob)) - (cond - (node-sym - (list node-name (get node-sym 'word-help-real-name))) - (next-nodes (word-help-index-search-nodes entry next-nodes))))) - -;;; Switch to a node in an index - -(defun word-help-goto-index-node (index-info) - "Jumps to an index node. -`index-info' should be a list with the following format: - -\(FILE-NAME INDEX-NODE-NAME INDEX-ENTRY KEYWORD)" - - (let* ((file-name (car index-info)) - (node-name (nth 1 index-info)) - (entry-name (nth 2 index-info)) - (kw-name (nth 3 index-info)) - (buffer (current-buffer))) - (if word-help-split-window - (pop-to-buffer nil)) - (Info-goto-node (concat "(" file-name ")" node-name)) - (Info-menu entry-name) -;; Do magic keyword search - (if word-help-magic-index - (let (end-point regs this-re found entry-re) - (setq entry-re (regexp-quote kw-name) - regs (list (concat - (if (string-match "^[A-Za-z]" entry-name) - "\\<" "") - entry-re - (if (string-match "[A-Za-z]$" entry-name) - "\\>" "")) - (concat "[`\"\(]" entry-re) - (concat "^" entry-re - (if (string-match "[A-Za-z]$" entry-name) - "\\>" "")))) - (end-of-line) - (setq end-point (point)) - (beginning-of-line) - (if (not (re-search-forward (car regs) end-point t)) - (while (and (not found) (car regs)) - (setq this-re (car regs) - regs (cdr regs) - found (re-search-forward this-re nil t)))) - (recenter 0))) - (if word-help-split-window - (pop-to-buffer buffer)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Completion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - -(defun word-help-extract-matches (from-ob dest-ob re-list) - "Takes atoms from from-ob, and puts them in dest-ob if they match re-list." - (let ((regexp (car (car re-list)))) - (mapatoms (lambda (x) - (if (or (not regexp) (string-match regexp (symbol-name x))) - (intern (symbol-name x) dest-ob))) - from-ob) - (if (cdr re-list) - (word-help-extract-matches from-ob dest-ob (cdr re-list)))) - dest-ob) - -(defun word-help-make-complete () - "Generates the `word-help-complete-index'." - (if word-help-complete-index - nil - (word-help-find-help-file) - (cond - ((symbolp word-help-complete-list) - (setq word-help-complete-index word-help-complete-list)) - (t - (word-help-process-indexes) - (if (not (atom word-help-main-index)) - (let ((from-ob (car word-help-main-index))) - (message "Processing keywords...") - (setq word-help-complete-index - (mapcar - (lambda (cmpl) - (let - ((regexp (car cmpl)) - (subm (cond ((nth 1 cmpl)) (0))) - (app (cond ((nth 2 cmpl)) (""))) - (re-list (cond ((nth 3 cmpl)) ('(("."))))) - (obarr (make-vector 47 0))) - (list regexp subm subm app - (word-help-extract-matches from-ob obarr - re-list)))) - word-help-complete-list)))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Misc. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;;; Default mapping - -(defun word-help-make-default-map (list vars) - "Makes a default mapping for `vars', which must be listed in order. -vars is a list of quoted symbols. If the nth entry in the list is -non-nil, the nth variable will be given this value. If nil, the var -will be given the global default value." - (set (car vars) (cond ((car list)) ((default-value (car vars))))) - (if (cdr vars) - (word-help-make-default-map (cdr list) (cdr vars)))) - -(provide 'word-help) - -;;; word-help.el ends here
--- a/lisp/gnus/=md5.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,409 +0,0 @@ -;;; md5.el -- MD5 Message Digest Algorithm -;;; Gareth Rees <gdr11@cl.cam.ac.uk> - -;; LCD Archive Entry: -;; md5|Gareth Rees|gdr11@cl.cam.ac.uk| -;; MD5 cryptographic message digest algorithm| -;; 13-Nov-95|1.0|~/misc/md5.el.Z| - -;;; Details: ------------------------------------------------------------------ - -;; This is a direct translation into Emacs LISP of the reference C -;; implementation of the MD5 Message-Digest Algorithm written by RSA -;; Data Security, Inc. -;; -;; The algorithm takes a message (that is, a string of bytes) and -;; computes a 16-byte checksum or "digest" for the message. This digest -;; is supposed to be cryptographically strong in the sense that if you -;; are given a 16-byte digest D, then there is no easier way to -;; construct a message whose digest is D than to exhaustively search the -;; space of messages. However, the robustness of the algorithm has not -;; been proven, and a similar algorithm (MD4) was shown to be unsound, -;; so treat with caution! -;; -;; The C algorithm uses 32-bit integers; because GNU Emacs -;; implementations provide 28-bit integers (with 24-bit integers on -;; versions prior to 19.29), the code represents a 32-bit integer as the -;; cons of two 16-bit integers. The most significant word is stored in -;; the car and the least significant in the cdr. The algorithm requires -;; at least 17 bits of integer representation in order to represent the -;; carry from a 16-bit addition. - -;;; Usage: -------------------------------------------------------------------- - -;; To compute the MD5 Message Digest for a message M (represented as a -;; string or as a vector of bytes), call -;; -;; (md5-encode M) -;; -;; which returns the message digest as a vector of 16 bytes. If you -;; need to supply the message in pieces M1, M2, ... Mn, then call -;; -;; (md5-init) -;; (md5-update M1) -;; (md5-update M2) -;; ... -;; (md5-update Mn) -;; (md5-final) - -;;; Copyright and licence: ---------------------------------------------------- - -;; Copyright (C) 1995 by Gareth Rees -;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm -;; -;; md5.el 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. -;; -;; md5.el 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. -;; -;; The original copyright notice is given below, as required by the -;; licence for the original code. This code is distributed under *both* -;; RSA's original licence and the GNU General Public Licence. (There -;; should be no problems, as the former is more liberal than the -;; latter). - -;;; Original copyright notice: ------------------------------------------------ - -;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. -;; -;; License to copy and use this software is granted provided that it is -;; identified as the "RSA Data Security, Inc. MD5 Message- Digest -;; Algorithm" in all material mentioning or referencing this software or -;; this function. -;; -;; License is also granted to make and use derivative works provided -;; that such works are identified as "derived from the RSA Data -;; Security, Inc. MD5 Message-Digest Algorithm" in all material -;; mentioning or referencing the derived work. -;; -;; RSA Data Security, Inc. makes no representations concerning either -;; the merchantability of this software or the suitability of this -;; software for any particular purpose. It is provided "as is" without -;; express or implied warranty of any kind. -;; -;; These notices must be retained in any copies of any part of this -;; documentation and/or software. - -;;; Code: --------------------------------------------------------------------- - -(defvar md5-program "md5" - "*Program that reads a message on its standard input and writes an -MD5 digest on its output.") - -(defvar md5-maximum-internal-length 4096 - "*The maximum size of a piece of data that should use the MD5 routines -written in lisp. If a message exceeds this, it will be run through an -external filter for processing. Also see the `md5-program' variable. -This variable has no effect if you call the md5-init|update|final -functions - only used by the `md5' function's simpler interface.") - -(defvar md5-bits (make-vector 4 0) - "Number of bits handled, modulo 2^64. -Represented as four 16-bit numbers, least significant first.") -(defvar md5-buffer (make-vector 4 '(0 . 0)) - "Scratch buffer (four 32-bit integers).") -(defvar md5-input (make-vector 64 0) - "Input buffer (64 bytes).") - -(defun md5-unhex (x) - (if (> x ?9) - (if (>= x ?a) - (+ 10 (- x ?a)) - (+ 10 (- x ?A))) - (- x ?0))) - -(defun md5-encode (message) - "Encodes MESSAGE using the MD5 message digest algorithm. -MESSAGE must be a string or an array of bytes. -Returns a vector of 16 bytes containing the message digest." - (if (<= (length message) md5-maximum-internal-length) - (progn - (md5-init) - (md5-update message) - (md5-final)) - (save-excursion - (set-buffer (get-buffer-create " *md5-work*")) - (erase-buffer) - (insert message) - (call-process-region (point-min) (point-max) - (or shell-file-name "/bin/sh") - t (current-buffer) nil - "-c" md5-program) - ;; MD5 digest is 32 chars long - ;; mddriver adds a newline to make neaten output for tty - ;; viewing, make sure we leave it behind. - (let ((data (buffer-substring (point-min) (+ (point-min) 32))) - (vec (make-vector 16 0)) - (ctr 0)) - (while (< ctr 16) - (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2)))) - (md5-unhex (aref data (1+ (* ctr 2)))))) - (setq ctr (1+ ctr))))))) - -(defsubst md5-add (x y) - "Return 32-bit sum of 32-bit integers X and Y." - (let ((m (+ (car x) (car y))) - (l (+ (cdr x) (cdr y)))) - (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535)))) - -;; FF, GG, HH and II are basic MD5 functions, providing transformations -;; for rounds 1, 2, 3 and 4 respectively. Each function follows this -;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x -;; by y bits to the left): -;; -;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b -;; -;; so we use the macro `md5-make-step' to construct each one. The -;; helper functions F, G, H and I operate on 16-bit numbers; the full -;; operation splits its inputs, operates on the halves separately and -;; then puts the results together. - -(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z))) -(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z)))) -(defsubst md5-H (x y z) (logxor x y z)) -(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z))))) - -(defmacro md5-make-step (name func) - (` - (defun (, name) (a b c d x s ac) - (let* - ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac))) - (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac))) - (m2 (logand 65535 (+ m1 (lsh l1 -16)))) - (l2 (logand 65535 l1)) - (m3 (logand 65535 (if (> s 15) - (+ (lsh m2 (- s 32)) (lsh l2 (- s 16))) - (+ (lsh m2 s) (lsh l2 (- s 16)))))) - (l3 (logand 65535 (if (> s 15) - (+ (lsh l2 (- s 32)) (lsh m2 (- s 16))) - (+ (lsh l2 s) (lsh m2 (- s 16))))))) - (md5-add (cons m3 l3) b))))) - -(md5-make-step md5-FF md5-F) -(md5-make-step md5-GG md5-G) -(md5-make-step md5-HH md5-H) -(md5-make-step md5-II md5-I) - -(defun md5-init () - "Initialise the state of the message-digest routines." - (aset md5-bits 0 0) - (aset md5-bits 1 0) - (aset md5-bits 2 0) - (aset md5-bits 3 0) - (aset md5-buffer 0 '(26437 . 8961)) - (aset md5-buffer 1 '(61389 . 43913)) - (aset md5-buffer 2 '(39098 . 56574)) - (aset md5-buffer 3 '( 4146 . 21622))) - -(defun md5-update (string) - "Update the current MD5 state with STRING (an array of bytes)." - (let ((len (length string)) - (i 0) - (j 0)) - (while (< i len) - ;; Compute number of bytes modulo 64 - (setq j (% (/ (aref md5-bits 0) 8) 64)) - - ;; Store this byte (truncating to 8 bits to be sure) - (aset md5-input j (logand 255 (aref string i))) - - ;; Update number of bits by 8 (modulo 2^64) - (let ((c 8) (k 0)) - (while (and (> c 0) (< k 4)) - (let ((b (aref md5-bits k))) - (aset md5-bits k (logand 65535 (+ b c))) - (setq c (if (> b (- 65535 c)) 1 0) - k (1+ k))))) - - ;; Increment number of bytes processed - (setq i (1+ i)) - - ;; When 64 bytes accumulated, pack them into sixteen 32-bit - ;; integers in the array `in' and then tranform them. - (if (= j 63) - (let ((in (make-vector 16 (cons 0 0))) - (k 0) - (kk 0)) - (while (< k 16) - (aset in k (md5-pack md5-input kk)) - (setq k (+ k 1) kk (+ kk 4))) - (md5-transform in)))))) - -(defun md5-pack (array i) - "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer." - (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2))) - (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0))))) - -(defun md5-byte (array n b) - "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers." - (let ((e (aref array n))) - (cond ((eq b 0) (logand 255 (cdr e))) - ((eq b 1) (lsh (cdr e) -8)) - ((eq b 2) (logand 255 (car e))) - ((eq b 3) (lsh (car e) -8))))) - -(defun md5-final () - (let ((in (make-vector 16 (cons 0 0))) - (j 0) - (digest (make-vector 16 0)) - (padding)) - - ;; Save the number of bits in the message - (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0))) - (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2))) - - ;; Compute number of bytes modulo 64 - (setq j (% (/ (aref md5-bits 0) 8) 64)) - - ;; Pad out computation to 56 bytes modulo 64 - (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0)) - (aset padding 0 128) - (md5-update padding) - - ;; Append length in bits and transform - (let ((k 0) (kk 0)) - (while (< k 14) - (aset in k (md5-pack md5-input kk)) - (setq k (+ k 1) kk (+ kk 4)))) - (md5-transform in) - - ;; Store the results in the digest - (let ((k 0) (kk 0)) - (while (< k 4) - (aset digest (+ kk 0) (md5-byte md5-buffer k 0)) - (aset digest (+ kk 1) (md5-byte md5-buffer k 1)) - (aset digest (+ kk 2) (md5-byte md5-buffer k 2)) - (aset digest (+ kk 3) (md5-byte md5-buffer k 3)) - (setq k (+ k 1) kk (+ kk 4)))) - - ;; Return digest - digest)) - -;; It says in the RSA source, "Note that if the Mysterious Constants are -;; arranged backwards in little-endian order and decrypted with the DES -;; they produce OCCULT MESSAGES!" Security through obscurity? - -(defun md5-transform (in) - "Basic MD5 step. Transform md5-buffer based on array IN." - (let ((a (aref md5-buffer 0)) - (b (aref md5-buffer 1)) - (c (aref md5-buffer 2)) - (d (aref md5-buffer 3))) - (setq - a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104)) - d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934)) - c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891)) - b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974)) - a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015)) - d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730)) - c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939)) - b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145)) - a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128)) - d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407)) - c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473)) - b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230)) - a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386)) - d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075)) - c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294)) - b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081)) - a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570)) - d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888)) - c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121)) - b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114)) - a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189)) - d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203)) - c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009)) - b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456)) - a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710)) - d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006)) - c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463)) - b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357)) - a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653)) - d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976)) - c (md5-GG c d a b (aref in 7) 14 '(26479 . 729)) - b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594)) - a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658)) - d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105)) - c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866)) - b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348)) - a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972)) - d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161)) - c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296)) - b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240)) - a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454)) - d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234)) - c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421)) - b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429)) - a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305)) - d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397)) - c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992)) - b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117)) - a (md5-II a b c d (aref in 0) 6 '(62505 . 8772)) - d (md5-II d a b c (aref in 7) 10 '(17194 . 65431)) - c (md5-II c d a b (aref in 14) 15 '(43924 . 9127)) - b (md5-II b c d a (aref in 5) 21 '(64659 . 41017)) - a (md5-II a b c d (aref in 12) 6 '(25947 . 22979)) - d (md5-II d a b c (aref in 3) 10 '(36620 . 52370)) - c (md5-II c d a b (aref in 10) 15 '(65519 . 62589)) - b (md5-II b c d a (aref in 1) 21 '(34180 . 24017)) - a (md5-II a b c d (aref in 8) 6 '(28584 . 32335)) - d (md5-II d a b c (aref in 15) 10 '(65068 . 59104)) - c (md5-II c d a b (aref in 6) 15 '(41729 . 17172)) - b (md5-II b c d a (aref in 13) 21 '(19976 . 4513)) - a (md5-II a b c d (aref in 4) 6 '(63315 . 32386)) - d (md5-II d a b c (aref in 11) 10 '(48442 . 62005)) - c (md5-II c d a b (aref in 2) 15 '(10967 . 53947)) - b (md5-II b c d a (aref in 9) 21 '(60294 . 54161))) - - (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) - (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) - (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) - (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Here begins the merger with the XEmacs API and the md5.el from the URL -;;; package. Courtesy wmperry@spry.com -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun md5 (object &optional start end) - "Return the MD5 (a secure message digest algorithm) of an object. -OBJECT is either a string or a buffer. -Optional arguments START and END denote buffer positions for computing the -hash of a portion of OBJECT." - (let ((buffer nil)) - (unwind-protect - (save-excursion - (setq buffer (generate-new-buffer " *md5-work*")) - (set-buffer buffer) - (cond - ((bufferp object) - (insert-buffer-substring object start end)) - ((stringp object) - (insert (if (or start end) - (substring object start end) - object))) - (t nil)) - (prog1 - (if (<= (point-max) md5-maximum-internal-length) - (mapconcat - (function (lambda (node) (format "%02x" node))) - (md5-encode (buffer-string)) - "") - (call-process-region (point-min) (point-max) - (or shell-file-name "/bin/sh") - t buffer nil - "-c" md5-program) - ;; MD5 digest is 32 chars long - ;; mddriver adds a newline to make neaten output for tty - ;; viewing, make sure we leave it behind. - (buffer-substring (point-min) (+ (point-min) 32))) - (kill-buffer buffer))) - (and buffer (kill-buffer buffer) nil)))) - -(provide 'md5) - -;;; md5.el ends here ----------------------------------------------------------
--- a/lisp/gnus/=nnheaderxm.el Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -;;; nnheaderxm.el --- making Gnus backends work under XEmacs -;; Copyright (C) 1996,97 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> -;; Keywords: news - -;; 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: - -;;; Code: - -(eval-and-compile - (autoload 'nnheader-insert-file-contents "nnheader")) - -(defun nnheader-xmas-run-at-time (time repeat function &rest args) - (start-itimer - "nnheader-run-at-time" - `(lambda () - (,function ,@args)) - time repeat)) - -(defun nnheader-xmas-cancel-timer (timer) - (delete-itimer timer)) - -(defun nnheader-xmas-cancel-function-timers (function) - ) - -(defun nnheader-xmas-find-file-noselect (filename &optional nowarn rawfile) - "Read file FILENAME into a buffer and return the buffer. -If a buffer exists visiting FILENAME, return that one, but -verify that the file has not changed since visited or saved. -The buffer is not selected, just returned to the caller." - (setq filename - (abbreviate-file-name - (expand-file-name filename))) - (if (file-directory-p filename) - (if find-file-run-dired - (dired-noselect filename) - (error "%s is a directory." filename)) - (let* ((buf (get-file-buffer filename)) - (truename (abbreviate-file-name (file-truename filename))) - (number (nthcdr 10 (file-attributes truename))) - ;; Find any buffer for a file which has same truename. - (other (and (not buf) - (get-file-buffer filename))) - error) - ;; Let user know if there is a buffer with the same truename. - (when other - (or nowarn - (string-equal filename (buffer-file-name other)) - (message "%s and %s are the same file" - filename (buffer-file-name other))) - ;; Optionally also find that buffer. - (when (or (and (boundp 'find-file-existing-other-name) - find-file-existing-other-name) - find-file-visit-truename) - (setq buf other))) - (if buf - (or nowarn - (verify-visited-file-modtime buf) - (cond ((not (file-exists-p filename)) - (error "File %s no longer exists!" filename)) - ((yes-or-no-p - (if (string= (file-name-nondirectory filename) - (buffer-name buf)) - (format - (if (buffer-modified-p buf) - "File %s changed on disk. Discard your edits? " - "File %s changed on disk. Reread from disk? ") - (file-name-nondirectory filename)) - (format - (if (buffer-modified-p buf) - "File %s changed on disk. Discard your edits in %s? " - "File %s changed on disk. Reread from disk into %s? ") - (file-name-nondirectory filename) - (buffer-name buf)))) - (save-excursion - (set-buffer buf) - (revert-buffer t t))))) - (save-excursion -;;; The truename stuff makes this obsolete. -;;; (let* ((link-name (car (file-attributes filename))) -;;; (linked-buf (and (stringp link-name) -;;; (get-file-buffer link-name)))) -;;; (if (bufferp linked-buf) -;;; (message "Symbolic link to file in buffer %s" -;;; (buffer-name linked-buf)))) - (setq buf (create-file-buffer filename)) - ;; (set-buffer-major-mode buf) - (set-buffer buf) - (erase-buffer) - (if rawfile - (condition-case () - (nnheader-insert-file-contents filename t) - (file-error - ;; Unconditionally set error - (setq error t))) - (condition-case () - (insert-file-contents filename t) - (file-error - ;; Run find-file-not-found-hooks until one returns non-nil. - (or t ; (run-hook-with-args-until-success 'find-file-not-found-hooks) - ;; If they fail too, set error. - (setq error t))))) - ;; Find the file's truename, and maybe use that as visited name. - (setq buffer-file-truename truename) - (setq buffer-file-number number) - ;; On VMS, we may want to remember which directory in a search list - ;; the file was found in. - (and (eq system-type 'vax-vms) - (let (logical) - (when (string-match ":" (file-name-directory filename)) - (setq logical (substring (file-name-directory filename) - 0 (match-beginning 0)))) - (not (member logical find-file-not-true-dirname-list))) - (setq buffer-file-name buffer-file-truename)) - (when find-file-visit-truename - (setq buffer-file-name - (setq filename - (expand-file-name buffer-file-truename)))) - ;; Set buffer's default directory to that of the file. - (setq default-directory (file-name-directory filename)) - ;; Turn off backup files for certain file names. Since - ;; this is a permanent local, the major mode won't eliminate it. - (when (not (funcall backup-enable-predicate buffer-file-name)) - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t)) - (if rawfile - nil - (after-find-file error (not nowarn))))) - buf))) - -(fset 'nnheader-run-at-time 'nnheader-xmas-run-at-time) -(fset 'nnheader-cancel-timer 'nnheader-xmas-cancel-timer) -(fset 'nnheader-cancel-function-timers 'nnheader-xmas-cancel-function-timers) -(fset 'nnheader-find-file-noselect 'nnheader-xmas-find-file-noselect) - -(provide 'nnheaderxm) - -;;; nnheaderxm.el ends here.
--- a/lispref/=buffer-local.texi Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -@c -*-texinfo-*- -@setfilename ../info/locals -@node Standard Buffer-Local Variables, Standard Keymaps, Standard Errors, Top -@appendix Standard Buffer-Local Variables - - The table below shows all of the variables that are automatically -local (when set) in each buffer in Emacs Version 18 with the common -packages loaded. - -@table @code -@item abbrev-mode -@xref{Abbrevs}. - -@item auto-fill-function -@xref{Auto Filling}. - -@item buffer-auto-save-file-name -@xref{Auto-Saving}. - -@item buffer-backed-up -@xref{Backup Files}. - -@item buffer-display-table -@xref{Active Display Table}. - -@item buffer-file-name -@xref{Buffer File Name}. - -@item buffer-file-truename -@xref{Buffer File Name}. - -@item buffer-read-only -@xref{Read Only Buffers}. - -@item buffer-saved-size -@xref{Point}. - -@item case-fold-search -@xref{Searching and Case}. - -@item ctl-arrow -@xref{Control Char Display}. - -@item default-directory -@xref{System Environment}. - -@item fill-column -@xref{Auto Filling}. - -@item left-margin -@xref{Indentation}. - -@item list-buffers-directory -@xref{Buffer File Name}. - -@item local-abbrev-table -@xref{Abbrevs}. - -@item major-mode -@xref{Mode Help}. - -@item mark-ring -@xref{The Mark}. - -@item minor-modes -@xref{Minor Modes}. - -@item mode-name -@xref{Mode Line Variables}. - -@item overwrite-mode -@xref{Insertion}. - -@item paragraph-separate -@xref{Standard Regexps}. - -@item paragraph-start -@xref{Standard Regexps}. - -@item require-final-newline -@xref{Insertion}. - -@item selective-display -@xref{Selective Display}. - -@item selective-display-ellipses -@xref{Selective Display}. - -@item tab-width -@xref{Control Char Display}. - -@item truncate-lines -@xref{Truncation}. -@end table
--- a/nt/config.w95 Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,349 +0,0 @@ -/* GNU Emacs site configuration template file. -*- C -*- - Copyright (C) 1988, 1993, 1994 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. */ - - -/* No code in Emacs #includes config.h twice, but some of the code - intended to work with other packages as well (like gmalloc.c) - think they can include it as many times as they like. */ -#ifndef EMACS_CONFIG_H -#define EMACS_CONFIG_H - - -/* These are all defined in the top-level Makefile by configure. - They're here only for reference. */ - -/* Define LISP_FLOAT_TYPE if you want emacs to support floating-point - numbers. */ -#undef LISP_FLOAT_TYPE - -/* Define GNU_MALLOC if you want to use the *new* GNU memory allocator. */ -#undef GNU_MALLOC - -/* Define REL_ALLOC if you want to use the relocating allocator for - buffer space. */ -#undef REL_ALLOC - -/* Define HAVE_X_WINDOWS if you want to use the X window system. */ -#undef HAVE_X_WINDOWS - -/* Define HAVE_X11 if you want to use version 11 of X windows. - Otherwise, Emacs expects to use version 10. */ -#undef HAVE_X11 - -/* Define if using an X toolkit. */ -#undef USE_X_TOOLKIT - -/* Define this if you're using XFree386. */ -#undef HAVE_XFREE386 - -/* Define HAVE_X_MENU if you want to use the X window menu system. - This appears to work on some machines that support X - and not on others. */ -#undef HAVE_X_MENU - -/* Define if we have the X11R6 or newer version of Xt. */ -#undef HAVE_X11XTR6 - -/* Define if netdb.h declares h_errno. */ -#undef HAVE_H_ERRNO - -/* Nowadays we have frame objects even if we support only ASCII terminals. */ -#define MULTI_FRAME - -/* If we're using any sort of window system, define some consequences. */ -#ifdef HAVE_X_WINDOWS -#define HAVE_WINDOW_SYSTEM -#define MULTI_KBOARD -#define HAVE_FACES -#define HAVE_MOUSE -#endif - -/* Define USE_TEXT_PROPERTIES to support visual and other properties - on text. */ -#define USE_TEXT_PROPERTIES - -/* Define USER_FULL_NAME to return a string - that is the user's full name. - It can assume that the variable `pw' - points to the password file entry for this user. - - At some sites, the pw_gecos field contains - the user's full name. If neither this nor any other - field contains the right thing, use pw_name, - giving the user's login name, since that is better than nothing. */ -#define USER_FULL_NAME pw->pw_gecos - -/* Define AMPERSAND_FULL_NAME if you use the convention - that & in the full name stands for the login id. */ -#undef AMPERSAND_FULL_NAME - -/* Things set by --with options in the configure script. */ - -/* Define to support POP mail retrieval. */ -#undef MAIL_USE_POP - -/* Define to support Kerberos-authenticated POP mail retrieval. */ -#undef KERBEROS - -/* Define to support using a Hesiod database to find the POP server. */ -#undef HESIOD - -/* Some things figured out by the configure script, grouped as they are in - configure.in. */ -#ifndef _ALL_SOURCE /* suppress warning if this is pre-defined */ -#undef _ALL_SOURCE -#endif -#undef HAVE_SYS_SELECT_H -#undef HAVE_SYS_TIMEB_H -#undef HAVE_SYS_TIME_H -#undef HAVE_UNISTD_H -#undef HAVE_UTIME_H -#undef STDC_HEADERS -#undef TIME_WITH_SYS_TIME - -#undef HAVE_LIBDNET -#undef HAVE_LIBPTHREADS -#undef HAVE_LIBRESOLV - -#undef HAVE_ALLOCA_H - -#undef HAVE_GETTIMEOFDAY -#undef GETTIMEOFDAY_ONE_ARGUMENT -#undef HAVE_GETHOSTNAME -#undef HAVE_DUP2 -#undef HAVE_RENAME -#undef HAVE_CLOSEDIR - -#undef TM_IN_SYS_TIME -#undef HAVE_TM_ZONE -#undef HAVE_TZNAME - -#undef const - -#undef HAVE_LONG_FILE_NAMES - -#undef CRAY_STACKSEG_END - -#undef UNEXEC_SRC - -#undef HAVE_LIBXBSD -#undef HAVE_XRMSETDATABASE -#undef HAVE_XSCREENRESOURCESTRING -#undef HAVE_XSCREENNUMBEROFSCREEN -#undef HAVE_XSETWMPROTOCOLS - -#undef HAVE_MKDIR -#undef HAVE_RMDIR -#undef HAVE_RANDOM -#undef HAVE_LRAND48 -#undef HAVE_BCOPY -#undef HAVE_BCMP -#undef HAVE_LOGB -#undef HAVE_FREXP -#undef HAVE_FMOD -#undef HAVE_FTIME -#undef HAVE_RES_INIT /* For -lresolv on Suns. */ -#undef HAVE_SETSID -#undef HAVE_FPATHCONF -#undef HAVE_SELECT -#undef HAVE_MKTIME -#undef HAVE_EACCESS -#undef HAVE_GETPAGESIZE -#undef HAVE_INET_SOCKETS - -#undef HAVE_AIX_SMT_EXP - -/* Define if you have the ANSI `strerror' function. - Otherwise you must have the variable `char *sys_errlist[]'. */ -#undef HAVE_STRERROR - -#undef HAVE_UTIMES - -/* Define if `sys_siglist' is declared by <signal.h>. */ -#undef SYS_SIGLIST_DECLARED - -/* Define if `struct utimbuf' is declared by <utime.h>. */ -#undef HAVE_STRUCT_UTIMBUF - -/* Define if `struct timeval' is declared by <sys/time.h>. */ -#undef HAVE_TIMEVAL - -/* If using GNU, then support inline function declarations. */ -#ifdef __GNUC__ -#define INLINE __inline__ -#else -#define INLINE -#endif - -#undef EMACS_CONFIGURATION - -#undef EMACS_CONFIG_OPTIONS - -/* The configuration script defines opsysfile to be the name of the - s/SYSTEM.h file that describes the system type you are using. The file - is chosen based on the configuration name you give. - - See the file ../etc/MACHINES for a list of systems and the - configuration names to use for them. - - See s/template.h for documentation on writing s/SYSTEM.h files. */ -#undef config_opsysfile -#include "s/windows95.h" - -/* The configuration script defines machfile to be the name of the - m/MACHINE.h file that describes the machine you are using. The file is - chosen based on the configuration name you give. - - See the file ../etc/MACHINES for a list of machines and the - configuration names to use for them. - - See m/template.h for documentation on writing m/MACHINE.h files. */ -#undef config_machfile -#include "m/intel386.h" - -/* These typedefs shouldn't appear when alloca.s or Makefile.in - includes config.h. */ -#ifndef NOT_C_CODE -#ifndef SPECIAL_EMACS_INT -typedef long EMACS_INT; -typedef unsigned long EMACS_UINT; -#endif -#endif - -/* Load in the conversion definitions if this system - needs them and the source file being compiled has not - said to inhibit this. There should be no need for you - to alter these lines. */ - -#ifdef SHORTNAMES -#ifndef NO_SHORTNAMES -#include "../shortnames/remap.h" -#endif /* not NO_SHORTNAMES */ -#endif /* SHORTNAMES */ - -/* If no remapping takes place, static variables cannot be dumped as - pure, so don't worry about the `static' keyword. */ -#ifdef NO_REMAP -#undef static -#endif - -/* Define `subprocesses' should be defined if you want to - have code for asynchronous subprocesses - (as used in M-x compile and M-x shell). - These do not work for some USG systems yet; - for the ones where they work, the s/SYSTEM.h file defines this flag. */ - -#ifndef VMS -#ifndef USG -/* #define subprocesses */ -#endif -#endif - -/* Define LD_SWITCH_SITE to contain any special flags your loader may need. */ -#undef LD_SWITCH_SITE - -/* Define C_SWITCH_SITE to contain any special flags your compiler needs. */ -#undef C_SWITCH_SITE - -/* Define LD_SWITCH_X_SITE to contain any special flags your loader - may need to deal with X Windows. For instance, if you've defined - HAVE_X_WINDOWS above and your X libraries aren't in a place that - your loader can find on its own, you might want to add "-L/..." or - something similar. */ -#undef LD_SWITCH_X_SITE - -/* Define LD_SWITCH_X_SITE_AUX with an -R option - in case it's needed (for Solaris, for example). */ -#undef LD_SWITCH_X_SITE_AUX - -/* Define C_SWITCH_X_SITE to contain any special flags your compiler - may need to deal with X Windows. For instance, if you've defined - HAVE_X_WINDOWS above and your X include files aren't in a place - that your compiler can find on its own, you might want to add - "-I/..." or something similar. */ -#undef C_SWITCH_X_SITE - -/* Define STACK_DIRECTION here, but not if m/foo.h did. */ -#ifndef STACK_DIRECTION -#undef STACK_DIRECTION -#endif - -/* Define the return type of signal handlers if the s-xxx file - did not already do so. */ -#define RETSIGTYPE void - -/* SIGTYPE is the macro we actually use. */ -#ifndef SIGTYPE -#define SIGTYPE RETSIGTYPE -#endif - -#ifdef emacs /* Don't do this for lib-src. */ -/* Tell regex.c to use a type compatible with Emacs. */ -#define RE_TRANSLATE_TYPE Lisp_Object * -#endif - -/* The rest of the code currently tests the CPP symbol BSTRING. - Override any claims made by the system-description files. - Note that on some SCO version it is possible to have bcopy and not bcmp. */ -#undef BSTRING -#if defined (HAVE_BCOPY) && defined (HAVE_BCMP) -#define BSTRING -#endif - -/* Non-ANSI C compilers usually don't have volatile. */ -#ifndef HAVE_VOLATILE -#ifndef __STDC__ -#define volatile -#endif -#endif - -/* Some of the files of Emacs which are intended for use with other - programs assume that if you have a config.h file, you must declare - the type of getenv. - - This declaration shouldn't appear when alloca.s or Makefile.in - includes config.h. */ -#ifndef NOT_C_CODE -extern char *getenv (); -#endif - -#endif /* EMACS_CONFIG_H */ - -/* These default definitions are good for almost all machines. - The exceptions override them in m/*.h. */ - -#ifndef BITS_PER_CHAR -#define BITS_PER_CHAR 8 -#endif - -#ifndef BITS_PER_SHORT -#define BITS_PER_SHORT 16 -#endif - -/* Note that lisp.h uses this in a preprocessor conditional, so it - would not work to use sizeof. That being so, we do all of them - without sizeof, for uniformity's sake. */ -#ifndef BITS_PER_INT -#define BITS_PER_INT 32 -#endif - -#ifndef BITS_PER_LONG -#define BITS_PER_LONG 32 -#endif
--- a/nt/debug.bat Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -@echo off -set emacs_dir=c:\emacs - -REM Here begins emacs.bat.in - -REM Set OS specific values. -set ARCH_SAVE=%PROCESSOR_ARCHITECTURE% -set PROCESSOR_ARCHITECTURE= -if "%ARCH_SAVE%" == "%PROCESSOR_ARCHITECTURE%" goto win95 -set PROCESSOR_ARCHITECTURE=%ARCH_SAVE% -set SHELL=cmd -goto next - -:win95 -set SHELL=command - -:next - -set EMACSLOADPATH=%emacs_dir%\lisp -set EMACSDATA=%emacs_dir%\etc -set EMACSPATH=%emacs_dir%\bin -set EMACSLOCKDIR=%emacs_dir%\lock -set INFOPATH=%emacs_dir%\info -set EMACSDOC=%emacs_dir%\etc -set TERM=CMD - -REM The variable HOME is used to find the startup file, ~\_emacs. Ideally, -REM this will not be set in this file but should already be set before -REM this file is invoked. If HOME is not set, use some generic default. - -set HOME_SAVE=%HOME% -set HOME_EXISTS=yes -set HOME_DEFAULT=C:\ -set HOME= -if "%HOME%" == "%HOME_SAVE%" set HOME_EXISTS=no -if "%HOME_EXISTS%" == "yes" set HOME=%HOME_SAVE% -if "%HOME_EXISTS%" == "no" set HOME=%HOME_DEFAULT% -if "%HOME_EXISTS%" == "no" echo HOME is not set! Using %HOME% as a default... - -start c:\msdev\bin\msdev -nologo %emacs_dir%\bin\emacs.exe %1 %2 %3 %4 %5 %6 %7 %8 %9
--- a/nt/emacs.bat Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,44 +0,0 @@ -@echo off - -REM Change this to the directory into which you installed Emacs: -set emacs_path=C:\emacs - -REM -REM You shouldn't have to change any of the below. -REM - -REM Set OS specific values. -set ARCH_SAVE=%PROCESSOR_ARCHITECTURE% -set PROCESSOR_ARCHITECTURE= -if "%ARCH_SAVE%" == "%PROCESSOR_ARCHITECTURE%" goto win95 -set PROCESSOR_ARCHITECTURE=%ARCH_SAVE% -set SHELL=cmd -goto next - -:win95 -set SHELL=command - -:next - -set EMACSLOADPATH=%emacs_path%\lisp -set EMACSDATA=%emacs_path%\etc -set EMACSPATH=%emacs_path%\bin -set EMACSLOCKDIR=%emacs_path%\lock -set INFOPATH=%emacs_path%\info -set EMACSDOC=%emacs_path%\etc -set TERM=CMD - -REM The variable HOME is used to find the startup file, ~\_emacs. Ideally, -REM this will not be set in this file but should already be set before -REM this file is invoked. If HOME is not set, use some generic default. - -set HOME_SAVE=%HOME% -set HOME_EXISTS=yes -set HOME_DEFAULT=C:\ -set HOME= -if "%HOME%" == "%HOME_SAVE%" set HOME_EXISTS=no -if "%HOME_EXISTS%" == "yes" set HOME=%HOME_SAVE% -if "%HOME_EXISTS%" == "no" set HOME=%HOME_DEFAULT% -if "%HOME_EXISTS%" == "no" echo HOME is not set! Using %HOME% as a default... - -%emacs_path%\bin\emacs.exe %1 %2 %3 %4 %5 %6 %7 %8 %9
--- a/nt/install Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,88 +0,0 @@ - Building and Installing Emacs - on Windows NT and Windows 95 - -You need a compiler package to build and install Emacs on NT or Win95. -If you don't have one, precompiled versions are available in -ftp://ftp.cs.washington.edu/pub/ntemacs/<version>. - -Configuring: - -(1) In previous versions, you needed to edit makefile.def - to reflect the compiler package that you are using. You should no - longer have to do this if you have defined the INCLUDE and LIB - environment variables, as is customary for use with Windows compilers. - (Unless you are using MSVCNT 1.1, in which case you will need - to set MSVCNT11 to be a non-zero value at the top of makefile.def.) - -(2) Choose the directory into which Emacs will be installed, and - edit makefile.def to define INSTALL_DIR to be this directory. - (Alternatively, if you have INSTALL_DIR set as an environment - variable, the build process will ignore the value in makefile.def - and use the value of the environment variable instead.) Note - that if it is not installed in the directory in which it is built, - the ~16 MB of lisp files will be copied into the installation directory. - - Also, makefile.def is sometimes unpacked read-only; use - - > attrib -r makefile.def - - to make it writable. - -(3) You may need to edit nt/paths.h to specify some other device - instead of `C:'. - -Building: - -(4) The target to compile the sources is "all", and is recursive starting - one directory up. The makefiles for the NT port are in files named - "makefile.nt". To get things started, type in this directory: - - > nmake -f makefile.nt all - - or use the ebuild.bat file. - - When the files are compiled, you will see some warning messages declaring - that some functions don't return a value, or that some data conversions - will be lossy, etc. You can safely ignore these messages. The warnings - may be fixed in the main FSF source at some point, but until then we - will just live with them. - - NOTE: You should not have to edit src\paths.h to get Emacs to run - correctly. All of the variables in src\paths.h are configured - during start up using the nt\emacs.bat file (which gets installed - as bin\emacs.bat -- see below). - -Installing: - -(5) Currently, Emacs requires a number of environment variables to be set - for it to run correctly. A batch file, emacs.bat, is provided that - sets these variables appropriately and then runs the executable - (emacs.bat is generated using the definition of INSTALL_DIR in - nt\makefile.def and the contents of nt\emacs.bat.in). - -(6) The install process will install the files necessary to run Emacs in - INSTALL_DIR (which may be the directory in which it was built), - and create a program manager/folder icon in a folder called GNU Emacs. - From this directory, type: - - > nmake -f makefile.nt install - - or use the install.bat file. - -(7) Create the Emacs startup file. Under Unix, this file is .emacs; - under NT and Win95, this files is _emacs. (If you would like to - use a .emacs file that, for example, you share with a Unix version - of Emacs, you can invoke Emacs with the -l option to specify the - .emacs file that you would like to load.) Note that Emacs requires - the environment variable HOME to be set in order for it to locate the - _emacs file. Ideally, HOME should not be set in the emacs.bat file - as it will be different for each user. (HOME could be set, - for example, in the System panel of the Control Panel). - -(8) Either click on the icon, or run the emacs.bat file, and away you go. - - If you would like to resize the command window that Emacs uses, - or change the font or colors, click on the program manager icon - to start Emacs. Change the settings using the "-" menu in the upper - left hand corner of the window, making sure to select the "Save" - options in the dialog boxes as you do so. Exit Emacs and restart.
--- a/src/=Makefile.in Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ -# DIST: This is the distribution Makefile for Emacs. configure can -# DIST: make most of the changes to this file you might want, so try -# DIST: that first. - -MAKE = make -# BSD doesn't have it as a default. - -# ==================== Things `configure' might edit ==================== - -CC=cc -CPP=cc -E -CFLAGS=-g -C_SWITCH_SYSTEM= -srcdir=@srcdir@/src -VPATH=@srcdir@/src -LN_S=ln -s - -# ============================= Targets ============================== - -CPP = $(CC) -E -Is -Im -#Note: an alternative is CPP = /lib/cpp - -# Just to avoid uncertainty. -SHELL = /bin/sh - -SUBMAKEFLAGS = CC='${CC}' LN_S='${LN_S}' CFLAGS='${CFLAGS}' MAKE='${MAKE}' - -all: doall - -doall: xmakefile - $(MAKE) ${SUBMAKEFLAGS} -f xmakefile ${MFLAGS} all - -mostlyclean: - rm -f temacs prefix-args xmakefile* core \#* *.o libXMenu11.a - rm -f ../etc/DOC -clean: mostlyclean - rm -f emacs-* emacs -#This is used in making a distribution. -#Do not use it on development directories! -distclean: clean - rm -f paths.h config.h ../etc/DOC-* -realclean: distclean - rm -f TAGS -versionclean: - -rm -f emacs emacs-* ../etc/DOC* -extraclean: distclean - -rm -f *~ \#* m/*~ s/*~ - -emacs: doemacs - @true - -doemacs: xmakefile - $(MAKE) ${SUBMAKEFLAGS} -f xmakefile ${MFLAGS} emacs - -temacs: dotemacs - @true - -dotemacs: xmakefile - $(MAKE) ${SUBMAKEFLAGS} -f xmakefile ${MFLAGS} temacs - -SOURCES = *.[ch] [sm]/* COPYING Makefile.in ymakefile \ - config.h.in README COPYING ChangeLog vms.pp-trans -unlock: - chmod u+w $(SOURCES) - -relock: - chmod -w $(SOURCES) - chmod +w paths.h - -### Some makes, like Ultrix's make, complain if you put a comment in -### the middle of a rule's command list! Dummies. - -### The flags for optimization and debugging depend on the -### system, so take an ordinary CFLAGS value and choose the -### appropriate CPP symbols to use in ymakefile. -### If you have a problem with cc -E here, changing -### the definition of CPP above may fix it. - -# Remake xmakefile whenever we reconfigure even if config.h didn't change. -xmakefile: ymakefile config.h ../config.status - -rm -f xmakefile xmakefile.new junk.c junk.cpp - cp ${srcdir}/ymakefile junk.c - ${CPP} -I. -I${srcdir} ${C_SWITCH_SYSTEM} ${CFLAGS} junk.c > junk.cpp - < junk.cpp \ - sed -e 's/^#.*//' \ - -e 's/^[ \f\t][ \f\t]*$$//' \ - -e 's/^ / /' \ - -e 's|^\(srcdir *=\).*$$|\1'"${srcdir}"'|' \ - -e 's|^\(VPATH *=\).*$$|\1'"${srcdir}"'|' \ - | sed -n -e '/^..*$$/p' \ - > xmakefile.new - mv -f xmakefile.new xmakefile - chmod 444 xmakefile - rm -f junk.c junk.cpp - -tagsfiles = [a-z]*.h [a-z]*.c ../lisp/[a-z]*.el ../lisp/term/[a-z]*.el -TAGS: $(tagsfiles) - etags $(tagsfiles) -tags: TAGS -.PHONY: tags
--- a/src/=XTests.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,179 +0,0 @@ -#include <X11/Xlib.h> -#include <X11/X.h> -#include <X11/Xutil.h> -#include <X11/Xresource.h> -#include "XTests.h" -#include <stdio.h> - -static Display *dpy; - -static void -quit (dpy) - Display *dpy; -{ - XCloseDisplay (dpy); - exit (0); -} - -static Colormap screen_colormap; - -static unsigned long -obtain_color (color) - char *color; -{ - int exists; - XColor color_def; - - if (!screen_colormap) - screen_colormap = DefaultColormap (dpy, DefaultScreen (dpy)); - - exists = XParseColor (dpy, screen_colormap, color, &color_def) - && XAllocColor (dpy, screen_colormap, &color_def); - if (exists) - return color_def.pixel; - - fprintf (stderr, "Can't get color; using black."); - return BlackPixel (dpy, DefaultScreen (dpy)); -} - -static char *visual_strings[] = -{ - "StaticGray ", - "GrayScale ", - "StaticColor", - "PseudoColor", - "TrueColor ", - "DirectColor" -}; - -main (argc,argv) - int argc; - char *argv[]; -{ - char *dpy_string; - int n; - long mask; - Visual *my_visual; - XVisualInfo *vinfo, visual_template; - XEvent event; - Window window; - Screen *scr; - XGCValues gc_values; - GC fill_gc, pix_gc, line_xor_gc, line_xor_inv_gc; - int i; - int x, y, width, height, geometry, gravity; - char *geo; - char default_geo[] = "80x40+0+0"; - int depth; - Pixmap pix; - char *string = "Kill the head and the body will die."; - char dash_list[] = {4, 4}; - int dashes = 2; - - if (argc < 2) - dpy_string = "localhost:0.0"; - else - dpy_string = argv[1]; - - if (argc >= 3) - { - XSizeHints hints; - - printf ("Geometry: %s\t(default: %s)\n", argv[2], default_geo); - geo = argv[2]; - XWMGeometry (dpy, DefaultScreen (dpy), geo, default_geo, - 3, &hints, &x, &y, &width, &height, &gravity); - } - - dpy = XOpenDisplay (dpy_string); - if (!dpy) - { - printf ("Can' open display %s\n", dpy_string); - exit (1); - } - - window = XCreateSimpleWindow (dpy, DefaultRootWindow (dpy), - 300, 300, 300, 300, 1, - BlackPixel (dpy, DefaultScreen (dpy)), - WhitePixel (dpy, DefaultScreen (dpy))); - XSelectInput (dpy, window, ButtonPressMask | KeyPressMask - | EnterWindowMask | LeaveWindowMask); - - gc_values.foreground = obtain_color ("blue"); - gc_values.background = WhitePixel (dpy, DefaultScreen (dpy)); - fill_gc = XCreateGC (dpy, window, GCForeground | GCBackground, - &gc_values); - - gc_values.foreground = obtain_color ("red"); - gc_values.line_width = 3; - gc_values.line_style = LineOnOffDash; - gc_values.cap_style = CapRound; - gc_values.join_style = JoinRound; - line_xor_gc = XCreateGC (dpy, window, - GCForeground | GCBackground | GCLineStyle - | GCJoinStyle | GCCapStyle | GCLineWidth, - &gc_values); - XSetDashes (dpy, line_xor_gc, 0, dash_list, dashes); - - line_xor_inv_gc = XCreateGC (dpy, window, - GCForeground | GCBackground | GCLineWidth, - &gc_values); - - depth = DefaultDepthOfScreen (ScreenOfDisplay (dpy, DefaultScreen (dpy))); - pix = XCreateBitmapFromData (dpy, window, page_glyf_bits, - page_glyf_width, page_glyf_height); - - XMapWindow (dpy, window); - XFlush (dpy); - - while (1) - { - XNextEvent (dpy, &event); - switch (event.type) - { - case ButtonPress: - switch (event.xbutton.button) - { - case Button1: - XDrawLine (dpy, window, line_xor_gc, 25, 75, 300, 75); - break; - - case Button2: - XDrawLine (dpy, window, line_xor_inv_gc, 25, 25, 300, 25); - break; - - case Button3: - XDrawLine (dpy, window, line_xor_gc, 25, 25, 25, 125); - break; - } - break; - - case KeyPress: - { - char buf[20]; - int n; - XComposeStatus status; - KeySym keysym; - - n = XLookupString (&event, buf, 20, &keysym, - (XComposeStatus *) &status); - - if (n == 1 && buf[0] == 'q') - quit (dpy); - } - break; - - case EnterNotify: - XCopyPlane (dpy, pix, window, fill_gc, 0, 0, - page_glyf_width, page_glyf_height, 100, 100, 1L); - XFillRectangle (dpy, window, fill_gc, 50, 50, 50, 50); - break; - - case LeaveNotify: - XClearWindow (dpy, window); - break; - } - - XFlush (dpy); - } -}
--- a/src/=XTests.h Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -#define page_glyf_width 30 -#define page_glyf_height 10 -static char page_glyf_bits[] = { - 0xf0, 0xff, 0xff, 0x03, 0x08, 0x00, 0x00, 0x04, 0xc4, 0x19, 0xf3, 0x08, - 0x42, 0xa5, 0x14, 0x10, 0xc1, 0xa5, 0x70, 0x20, 0x41, 0xbc, 0x16, 0x20, - 0x42, 0xa4, 0x14, 0x10, 0x44, 0x24, 0xf3, 0x08, 0x08, 0x00, 0x00, 0x04, - 0xf0, 0xff, 0xff, 0x03};
--- a/src/=convexos.h Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -/* Definitions file for GNU Emacs running on ConvexOS. */ - -#include "bsd4-3.h" - -/* First pty name is /dev/pty?0. We have to search for it. */ -#undef FIRST_PTY_LETTER -#define FIRST_PTY_LETTER first_pty_letter - -/* getpgrp requires no arguments. */ -#define GETPGRP_NO_ARG
--- a/src/=environ.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,316 +0,0 @@ -/* Environment-hacking for GNU Emacs subprocess - Copyright (C) 1986 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 1, 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. */ - - -#include "config.h" -#include "lisp.h" - -#ifdef MAINTAIN_ENVIRONMENT - -#ifdef VMS -you lose -- this is un*x-only -#endif - -/* alist of (name-string . value-string) */ -Lisp_Object Venvironment_alist; -extern char **environ; - -void -set_environment_alist (str, val) - register Lisp_Object str, val; -{ - register Lisp_Object tem; - - tem = Fassoc (str, Venvironment_alist); - if (NULL (tem)) - if (NULL (val)) - ; - else - Venvironment_alist = Fcons (Fcons (str, val), Venvironment_alist); - else - if (NULL (val)) - Venvironment_alist = Fdelq (tem, Venvironment_alist); - else - XCONS (tem)->cdr = val; -} - - - -static void -initialize_environment_alist () -{ - register unsigned char **e, *s; - extern char *index (); - - for (e = (unsigned char **) environ; *e; e++) - { - s = (unsigned char *) index (*e, '='); - if (s) - set_environment_alist (make_string (*e, s - *e), - build_string (s + 1)); - } -} - - -unsigned char * -getenv_1 (str, ephemeral) - register unsigned char *str; - int ephemeral; /* if ephmeral, don't need to gc-proof */ -{ - register Lisp_Object env; - int len = strlen (str); - - for (env = Venvironment_alist; CONSP (env); env = XCONS (env)->cdr) - { - register Lisp_Object car = XCONS (env)->car; - register Lisp_Object tem = XCONS (car)->car; - - if ((len == XSTRING (tem)->size) && - (!bcmp (str, XSTRING (tem)->data, len))) - { - /* Found it in the lisp environment */ - tem = XCONS (car)->cdr; - if (ephemeral) - /* Caller promises that gc won't make him lose */ - return XSTRING (tem)->data; - else - { - register unsigned char **e; - unsigned char *s; - int ll = XSTRING (tem)->size; - - /* Look for element in the original unix environment */ - for (e = (unsigned char **) environ; *e; e++) - if (!bcmp (str, *e, len) && *(*e + len) == '=') - { - s = *e + len + 1; - if (strlen (s) >= ll) - /* User hasn't either hasn't munged it or has set it - to something shorter -- we don't have to cons */ - goto copy; - else - goto cons; - }; - cons: - /* User has setenv'ed it to a diferent value, and our caller - isn't guaranteeing that he won't stash it away somewhere. - We can't just return a pointer to the lisp string, as that - will be corrupted when gc happens. So, we cons (in such - a way that it can't be freed -- though this isn't such a - problem since the only callers of getenv (as opposed to - those of egetenv) are very early, before the user -could- - have frobbed the environment. */ - s = (unsigned char *) xmalloc (ll + 1); - copy: - bcopy (XSTRING (tem)->data, s, ll + 1); - return (s); - } - } - } - return ((unsigned char *) 0); -} - -/* unsigned -- stupid delcaration in lisp.h */ char * -getenv (str) - register unsigned char *str; -{ - return ((char *) getenv_1 (str, 0)); -} - -unsigned char * -egetenv (str) - register unsigned char *str; -{ - return (getenv_1 (str, 1)); -} - - -#if (1 == 1) /* use caller-alloca versions, rather than callee-malloc */ -int -size_of_current_environ () -{ - register int size; - Lisp_Object tem; - - tem = Flength (Venvironment_alist); - - size = (XINT (tem) + 1) * sizeof (unsigned char *); - /* + 1 for environment-terminating 0 */ - - for (tem = Venvironment_alist; !NULL (tem); tem = XCONS (tem)->cdr) - { - register Lisp_Object str, val; - - str = XCONS (XCONS (tem)->car)->car; - val = XCONS (XCONS (tem)->car)->cdr; - - size += (XSTRING (str)->size + - XSTRING (val)->size + - 2); /* 1 for '=', 1 for '\000' */ - } - return size; -} - -void -get_current_environ (memory_block) - unsigned char **memory_block; -{ - register unsigned char **e, *s; - register int len; - register Lisp_Object tem; - - e = memory_block; - - tem = Flength (Venvironment_alist); - - s = (unsigned char *) memory_block - + (XINT (tem) + 1) * sizeof (unsigned char *); - - for (tem = Venvironment_alist; !NULL (tem); tem = XCONS (tem)->cdr) - { - register Lisp_Object str, val; - - str = XCONS (XCONS (tem)->car)->car; - val = XCONS (XCONS (tem)->car)->cdr; - - *e++ = s; - len = XSTRING (str)->size; - bcopy (XSTRING (str)->data, s, len); - s += len; - *s++ = '='; - len = XSTRING (val)->size; - bcopy (XSTRING (val)->data, s, len); - s += len; - *s++ = '\000'; - } - *e = 0; -} - -#else -/* dead code (this function mallocs, caller frees) superseded by above (which allows caller to use alloca) */ -unsigned char ** -current_environ () -{ - unsigned char **env; - register unsigned char **e, *s; - register int len, env_len; - Lisp_Object tem; - Lisp_Object str, val; - - tem = Flength (Venvironment_alist); - - env_len = (XINT (tem) + 1) * sizeof (char *); - /* + 1 for terminating 0 */ - - len = 0; - for (tem = Venvironment_alist; !NULL (tem); tem = XCONS (tem)->cdr) - { - str = XCONS (XCONS (tem)->car)->car; - val = XCONS (XCONS (tem)->car)->cdr; - - len += (XSTRING (str)->size + - XSTRING (val)->size + - 2); - } - - e = env = (unsigned char **) xmalloc (env_len + len); - s = (unsigned char *) env + env_len; - - for (tem = Venvironment_alist; !NULL (tem); tem = XCONS (tem)->cdr) - { - str = XCONS (XCONS (tem)->car)->car; - val = XCONS (XCONS (tem)->car)->cdr; - - *e++ = s; - len = XSTRING (str)->size; - bcopy (XSTRING (str)->data, s, len); - s += len; - *s++ = '='; - len = XSTRING (val)->size; - bcopy (XSTRING (val)->data, s, len); - s += len; - *s++ = '\000'; - } - *e = 0; - - return env; -} - -#endif /* dead code */ - - -DEFUN ("getenv", Fgetenv, Sgetenv, 1, 2, "sEnvironment variable: \np", - "Return the value of environment variable VAR, as a string.\n\ -When invoked interactively, print the value in the echo area.\n\ -VAR is a string, the name of the variable,\n\ - or the symbol t, meaning to return an alist representing the\n\ - current environment.") - (str, interactivep) - Lisp_Object str, interactivep; -{ - Lisp_Object val; - - if (str == Qt) /* If arg is t, return whole environment */ - return (Fcopy_alist (Venvironment_alist)); - - CHECK_STRING (str, 0); - val = Fcdr (Fassoc (str, Venvironment_alist)); - if (!NULL (interactivep)) - { - if (NULL (val)) - message ("%s not defined in environment", XSTRING (str)->data); - else - message ("\"%s\"", XSTRING (val)->data); - } - return val; -} - -DEFUN ("setenv", Fsetenv, Ssetenv, 1, 2, - "sEnvironment variable: \nsSet %s to value: ", - "Set the value of environment variable VAR to VALUE.\n\ -Both args must be strings. Returns VALUE.") - (str, val) - Lisp_Object str; - Lisp_Object val; -{ - Lisp_Object tem; - - CHECK_STRING (str, 0); - if (!NULL (val)) - CHECK_STRING (val, 0); - - set_environment_alist (str, val); - return val; -} - - -syms_of_environ () -{ - staticpro (&Venvironment_alist); - defsubr (&Ssetenv); - defsubr (&Sgetenv); -} - -init_environ () -{ - Venvironment_alist = Qnil; - initialize_environment_alist (); -} - -#endif /* MAINTAIN_ENVIRONMENT */
--- a/src/=mach2.h Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* Definitions for Emacs running on Mach version 2 (non-kernelized system). - Copyright (C) 1990 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, 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include "bsd4-3.h" - -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. We'll need to undo the bsd one. */ - -#undef SYSTEM_TYPE -#define SYSTEM_TYPE "next-mach" - -#define LD_SWITCH_SYSTEM -X -noseglinkedit - -/* Don't use -lc on the NeXT. */ -#define LIB_STANDARD -lsys_s -#define LIB_MATH -lm - -#define environ _environ - -#define START_FILES pre-crt0.o -#define UNEXEC unexnext.o - -/* start_of_text isn't actually used, so make it compile without error. */ -#define TEXT_START 0 -/* This seems to be right for end_of_text, but it may not be used anyway. */ -#define TEXT_END get_etext () -/* This seems to be right for end_of_data, but it may not be used anyway. */ -#define DATA_END get_edata () - -/* Defining KERNEL_FILE causes lossage because sys/file.h - stupidly gets confused by it. */ -#undef KERNEL_FILE
--- a/src/=old-ralloc.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1069 +0,0 @@ -/* Block-relocating memory allocator. - Copyright (C) 1990 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 1, 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. */ - -/* This package works by allocating blocks from a zone of memory - above that used by malloc (). When malloc needs more space that - would enter our zone, we relocate blocks upward. The bottom of - our zone is kept in the variable `virtual_break_value'. The top - of our zone is indicated by `real_break_value'. - - As blocks are freed, a free list is maintained and we attempt - to satisfy further requests for space using a first-fit policy. - If there are holes, but none fit, memory is compacted and a new - block is obtained at the top of the zone. - - NOTE that our blocks are always rounded to page boundaries. */ - -/* - NOTES: - - Once this is stable, I can speed things up by intially leaving a large - gap between real_break_value and true_break_value, or maybe making - a large hole before the first block. - - If we also kept track of size_wanted, we could gain some - extra space upon compactification. - - Perhaps we should just note a hole when malloc does doing sbrk(-n)? - - Relocating downward upon freeing the first block would simplify - other things. - - When r_alloc places a block in a hole, we could easily check if there's - much more than required, and leave a hole. - */ - -#include "mem_limits.h" - -static POINTER r_alloc_sbrk (); -static POINTER sbrk (); -static POINTER brk (); - -/* Variable `malloc' uses for the function which gets more space - from the system. */ -extern POINTER (*__morecore) (); - -/* List of variables which point into the associated data block. */ -struct other_pointer -{ - POINTER *location; - struct other_pointer *next; -}; - -/* List describing all the user's pointers to relocatable blocks. */ -typedef struct rel_pointers -{ - struct rel_pointers *next; - struct rel_pointers *prev; - struct other_pointer *others; /* Other variables which use this block. */ - POINTER *location; /* Location of the block's pointer. */ - POINTER block; /* Address of the actual data. */ - int size; /* The size of the block. */ -} relocatable_pointer; - -#define REL_NIL ((struct rel_pointers *) 0) - -static relocatable_pointer *pointer_list; -static relocatable_pointer *last_pointer; - -#define MAX_HOLES 2 - -/* Vector of available holes among allocated blocks. This can include - a hole at the beginning of the list, but never the end. */ -typedef struct -{ - POINTER address; - unsigned int size; -} hole_descriptor; - -static hole_descriptor r_alloc_holes[MAX_HOLES]; - -/* Number of holes currently available. */ -static int holes; - -/* The process break value (i.e., curbrk) */ -static POINTER real_break_value; - -/* The REAL (i.e., page aligned) break value. */ -static POINTER true_break_value; - -/* Address of start of data space in use by relocatable blocks. - This is what `malloc' thinks is the process break value. */ -static POINTER virtual_break_value; - -/* Nonzero if we have told `malloc' to start using `r_alloc_sbrk' - instead of calling `sbrk' directly. */ -int r_alloc_in_use; - -#define PAGE (getpagesize ()) -#define ALIGNED(addr) (((unsigned int) (addr) & (PAGE - 1)) == 0) -#define ROUNDUP(size) (((unsigned int) (size) + PAGE) & ~(PAGE - 1)) - -/* - Level number of warnings already issued. - 0 -- no warnings issued. - 1 -- 75% warning already issued. - 2 -- 85% warning already issued. -*/ -static int warnlevel; - -/* Function to call to issue a warning; - 0 means don't issue them. */ -static void (*warnfunction) (); - -/* Call this to start things off. It determines the current process - break value, as well as the `true' break value--because the system - allocates memory in page increments, if the break value is not page - aligned it means that space up to the next page boundary is actually - available. */ - -void -malloc_init (start, warn_func) - POINTER start; - void (*warn_func) (); -{ - r_alloc_in_use = 1; - __morecore = r_alloc_sbrk; - - virtual_break_value = real_break_value = sbrk (0); - if (ALIGNED (real_break_value)) - true_break_value = real_break_value; - else - true_break_value = (POINTER) ROUNDUP (real_break_value); - - if (start) - data_space_start = start; - lim_data = 0; - warnlevel = 0; - warnfunction = warn_func; - - get_lim_data (); -} - -/* Get more space for us to use. Return a pointer to SIZE more - bytes of space. SIZE is internally rounded up to a page boundary, - and requests for integral pages prefetch an extra page. */ - -static POINTER -get_more_space (size) - unsigned int size; -{ - unsigned int margin = true_break_value - real_break_value; - unsigned int get; - POINTER old_break = real_break_value; - - if (size == 0) - return real_break_value; - - if (size <= margin) - { - real_break_value += size; - return old_break; - } - - get = ROUNDUP (size - margin); - if (sbrk (get) < (POINTER) 0) - return NULL; - - true_break_value += get; - real_break_value = (old_break + size); - - return old_break; -} - -/* Relinquish size bytes of space to the system. Space is only returned - in page increments. If successful, return real_break_value. */ - -static POINTER -return_space (size) - unsigned int size; -{ - unsigned int margin = (true_break_value - real_break_value) + size; - unsigned int to_return = (margin / PAGE) * PAGE; - unsigned new_margin = margin % PAGE; - - true_break_value -= to_return; - if (! brk (true_break_value)) - return NULL; - - real_break_value = true_break_value - new_margin; - return real_break_value; -} - -/* Record a new hole in memory beginning at ADDRESS of size SIZE. - Holes are ordered by location. Adjacent holes are merged. - Holes are zero filled before being noted. */ - -static void -note_hole (address, size) - POINTER address; - int size; -{ - register int this_hole = holes - 1; /* Start at the last hole. */ - register POINTER end = address + size; /* End of the hole. */ - register int i; - - if (holes) - { - /* Find the hole which should precede this new one. */ - while (this_hole >= 0 && r_alloc_holes[this_hole].address > address) - this_hole--; - - /* Can we merge with preceding? */ - if (this_hole >= 0 - && r_alloc_holes[this_hole].address + r_alloc_holes[this_hole].size - == address) - { - r_alloc_holes[this_hole].size += size; - - if (this_hole == holes - 1) - return; - - /* Can we also merge with following? */ - if (end == r_alloc_holes[this_hole + 1].address) - { - r_alloc_holes[this_hole].size - += r_alloc_holes[this_hole + 1].size; - - for (i = this_hole + 1; i < holes - 1; i++) - r_alloc_holes[i] = r_alloc_holes[i + 1]; - holes--; - } - - return; - } - - if (this_hole < holes - 1) /* there are following holes */ - { - register int next_hole = this_hole + 1; - - /* Can we merge with the next hole? */ - if (end == r_alloc_holes[next_hole].address) - { - r_alloc_holes[next_hole].address = address; - r_alloc_holes[next_hole].size += size; - return; - } - - /* Can't merge, so insert. */ - for (i = holes; i > next_hole; i--) - r_alloc_holes[i] = r_alloc_holes[i - 1]; - r_alloc_holes[next_hole].address = address; - r_alloc_holes[next_hole].size = size; - holes++; - - return; - } - else /* Simply add this hole at the end. */ - { - r_alloc_holes[holes].address = address; - r_alloc_holes[holes].size = size; - holes++; - - return; - } - - abort (); - } - else /* Make the first hole. */ - { - holes = 1; - r_alloc_holes[0].address = address; - r_alloc_holes[0].size = size; - } -} - -/* Mark hole HOLE as no longer available by re-organizing the vector. - HOLE is the Nth hole, beginning with 0. This doesn *not* affect memory - organization. */ - -static void -delete_hole (hole) - int hole; -{ - register int i; - - for (i = hole; i < holes - 1; i++) - r_alloc_holes[i] = r_alloc_holes[i + 1]; - - holes--; -} - -/* Insert a newly allocated pointer, NEW_PTR, at the appropriate - place in our list. */ - -static void -insert (new_ptr) - register relocatable_pointer *new_ptr; -{ - register relocatable_pointer *this_ptr = pointer_list; - - while (this_ptr != REL_NIL && this_ptr->block < new_ptr->block) - this_ptr = this_ptr->next; - - if (this_ptr == REL_NIL) - abort (); /* Use `attach' for appending. */ - - new_ptr->next = this_ptr; - new_ptr->prev = this_ptr->prev; - this_ptr->prev = new_ptr; - - if (this_ptr == pointer_list) - pointer_list = new_ptr; - else - new_ptr->prev->next = new_ptr; -} - -/* Attach a newly allocated pointer, NEW_PTR, to the end of our list. */ - -static void -attach (new_ptr) - relocatable_pointer *new_ptr; -{ - if (pointer_list == REL_NIL) - { - pointer_list = new_ptr; - last_pointer = new_ptr; - new_ptr->next = new_ptr->prev = REL_NIL; - } - else - { - new_ptr->next = REL_NIL; - last_pointer->next = new_ptr; - new_ptr->prev = last_pointer; - last_pointer = new_ptr; - } -} - -static relocatable_pointer * -find_block (block) - POINTER block; -{ - register relocatable_pointer *this_ptr = pointer_list; - - while (this_ptr != REL_NIL && this_ptr->block != block) - this_ptr = this_ptr->next; - - return this_ptr; -} - -static relocatable_pointer * -find_location (address) - POINTER *address; -{ - register relocatable_pointer *this_ptr = pointer_list; - - while (this_ptr != REL_NIL && this_ptr->location != address) - { - struct other_pointer *op = this_ptr->others; - - while (op != (struct other_pointer *) 0) - { - if (op->location == address) - return this_ptr; - - op = op->next; - } - - this_ptr = this_ptr->next; - } - - return this_ptr; -} - - -static void compactify (); - -/* Record of last new block allocated. */ -static relocatable_pointer *last_record; - -/* Allocate a block of size SIZE and record that PTR points to it. - If successful, store the address of the block in *PTR and return - it as well. Otherwise return NULL. */ - -POINTER -r_alloc (ptr, size) - POINTER *ptr; - int size; -{ - register relocatable_pointer *record - = (relocatable_pointer *) malloc (sizeof (relocatable_pointer)); - register POINTER block; - - /* If we can't get space to record this pointer, fail. */ - if (record == 0) - return NULL; - - last_record = record; - - if (holes) /* Search for a hole the right size. */ - { - int i; - - for (i = 0; i < holes; i++) - if (r_alloc_holes[i].size >= size) - { - record->location = ptr; - record->others = (struct other_pointer *) 0; - record->block = *ptr = r_alloc_holes[i].address; - if (r_alloc_holes[i].size > ROUNDUP (size)) - { - record->size = ROUNDUP (size); - r_alloc_holes[i].size -= ROUNDUP (size); - r_alloc_holes[i].address += ROUNDUP (size); - } - else - { - record->size = r_alloc_holes[i].size; - delete_hole (i); - } - insert (record); - - *ptr = record->block; - return record->block; - } - - /* No holes large enough. Burp. */ - compactify (); - } - - /* No holes: grow the process. */ - block = get_more_space (size); - if (block == NULL) - { - free (record); - return NULL; - } - - /* Return the address of the block. */ - *ptr = block; - - /* Record and append this pointer to our list. */ - record->location = ptr; - record->others = (struct other_pointer *) 0; - record->block = block; - record->size = size; - attach (record); - - return block; -} - -/* Declare VAR to be a pointer which points into the block of r_alloc'd - memory at BLOCK. - - If VAR is already delcared for this block, simply return. - If VAR currently points to some other block, remove that declaration - of it, then install the new one. - - Return 0 if successful, -1 otherwise. */ - -int -r_alloc_declare (var, block) - POINTER *var; - register POINTER block; -{ - register relocatable_pointer *block_ptr = find_block (block); - relocatable_pointer *var_ptr = find_location (var); - register struct other_pointer *other; - - if (block_ptr == REL_NIL) - abort (); - - if (var_ptr != REL_NIL) /* Var already declared somewhere. */ - { - register struct other_pointer *po; - - if (var_ptr == block_ptr) /* Var already points to this block. */ - return 0; - - po = (struct other_pointer *) 0; - other = var_ptr->others; - while (other && other->location != var) - { - po = other; - other = other->next; - } - - if (!other) /* This only happens if the location is */ - abort (); /* the main pointer and not an `other' */ - - if (po) /* In the chain */ - { - po->next = other->next; - free (other); - } - else /* Only element of the chain */ - { - free (var_ptr->others); - var_ptr->others = (struct other_pointer *) 0; - } - } - - /* Install this variable as an `other' element */ - - other = (struct other_pointer *) malloc (sizeof (struct other_pointer)); - - if (other == 0) - return -1; - - /* If the malloc relocated this data block, adjust this variable. */ - if (block != block_ptr->block) - { - int offset = block_ptr->block - block; - - *var += offset; - } - - other->location = var; - other->next = (struct other_pointer *) 0; - - if (block_ptr->others == (struct other_pointer *) 0) - block_ptr->others = other; - else - { - register struct other_pointer *op = block_ptr->others; - - while (op->next != (struct other_pointer *) 0) - op = op->next; - op->next = other; - } - - return 0; -} - -/* Recursively free the linked list of `other' pointers to a block. */ - -static void -free_others (another) - struct other_pointer *another; -{ - if (another == (struct other_pointer *) 0) - return; - - free_others (another->next); - free (another); -} - -/* Remove the element pointed to by PTR from the doubly linked list. - Record the newly freed space in `holes', unless it was at the end, - in which case return that space to the system. Return 0 if successful, - -1 otherwise. */ - -int -r_alloc_free (ptr) - register POINTER *ptr; -{ - register relocatable_pointer *this_ptr = find_block (*ptr); - - if (this_ptr == REL_NIL) - return -1; - else - { - register relocatable_pointer *prev = this_ptr->prev; - register relocatable_pointer *next = this_ptr->next; - if (next && prev) /* Somewhere in the middle */ - { - next->prev = prev; - prev->next = next; - } - else if (prev) /* Last block */ - { - prev->next = REL_NIL; - last_pointer = prev; - return_space (this_ptr->size); - free_others (this_ptr->others); - free (this_ptr); - - return 0; - } - else if (next) /* First block */ - { - next->prev = REL_NIL; - pointer_list = next; - } - else if (this_ptr = pointer_list) /* ONLY block */ - { - pointer_list = REL_NIL; - last_pointer = REL_NIL; - if (holes) /* A hole precedes this block. */ - { - holes = 0; - return_space (real_break_value - virtual_break_value); - } - else - return_space (this_ptr->size); - - if (real_break_value != virtual_break_value) - abort (); - - free_others (this_ptr->others); - free (this_ptr); - /* Turn off r_alloc_in_use? */ - - return 0; - } - else - abort (); /* Weird shit */ - - free_others (this_ptr->others); - free (this_ptr); - bzero (this_ptr->block, this_ptr->size); - note_hole (this_ptr->block, this_ptr->size); - - if (holes == MAX_HOLES) - compactify (); - } - - return 0; -} - -/* Change the size of the block pointed to by the thing in PTR. - If neccessary, r_alloc a new block and copy the data there. - Return a pointer to the block if successfull, NULL otherwise. - - Note that if the size requested is less than the actual bloc size, - nothing is done and the pointer is simply returned. */ - -POINTER -r_re_alloc (ptr, size) - POINTER *ptr; - int size; -{ - register relocatable_pointer *this_ptr = find_block (*ptr); - POINTER block; - - if (! this_ptr) - return NULL; - - if (this_ptr->size >= size) /* Already have enough space. */ - return *ptr; - - /* Here we could try relocating the blocks just above... */ - block = r_alloc (ptr, size); - if (block) - { - bcopy (this_ptr->block, block, this_ptr->size); - if (this_ptr->others) - last_record->others = this_ptr->others; - - if (! r_alloc_free (this_ptr->block)) - abort (); - - *ptr = block; - return block; - } - - return NULL; -} - - -/* Move and relocate all blocks from FIRST_PTR to LAST_PTR, inclusive, - downwards to space starting at ADDRESS. */ - -static int -move_blocks_downward (first_ptr, last_ptr, address) - relocatable_pointer *first_ptr, *last_ptr; - POINTER address; -{ - int size = (last_ptr->block + last_ptr->size) - first_ptr->block; - register relocatable_pointer *this_ptr = first_ptr; - register offset = first_ptr->block - address; - register struct other_pointer *op; - - /* Move all the data. */ - bcopy (first_ptr->block, address, size); - - /* Now relocate all the pointers to those blocks. */ - while (1) - { - this_ptr->block -= offset; - *this_ptr->location = this_ptr->block; - - op = this_ptr->others; - while (op != (struct other_pointer *) 0) - { - *op->location -= offset; - op = op->next; - } - - if (this_ptr == last_ptr) - return; - else - this_ptr = this_ptr->next; - } - - return size; -} - -/* Burp our memory zone. */ - -static void -compactify () -{ - register relocatable_pointer *this_ptr = pointer_list; - relocatable_pointer *first_to_move; - register relocatable_pointer *last_to_move; - hole_descriptor *this_hole = &r_alloc_holes[0]; - register hole_descriptor *next_hole; - register POINTER end; /* First address after hole */ - unsigned int space_regained = 0; - - while (holes) /* While there are holes */ - { - /* Find the first block after this hole. */ - end = this_hole->address + this_hole->size; - while (this_ptr && this_ptr->block != end) - this_ptr = this_ptr->next; - - if (! this_ptr) - abort (); - - next_hole = this_hole + 1; - last_to_move = first_to_move = this_ptr; - this_ptr = this_ptr->next; - - /* Note all blocks located before the next hole. */ - while (this_ptr && this_ptr->block < next_hole->address) - { - last_to_move = this_ptr; - this_ptr = this_ptr->next; - } - space_regained += - move_blocks_downward (first_to_move, last_to_move, this_hole->address); - - holes--; - this_hole = next_hole; - } - - return_space (space_regained); -} - -/* Relocate the list elements from the beginning of the list up to and - including UP_TO_THIS_PTR to the area beginning at FREE_SPACE, which is - after all current blocks. - - First copy all the data, then adjust the pointers and reorganize - the list. NOTE that this *only* works for contiguous blocks. */ - -static unsigned int -relocate_to_end (up_to_this_ptr, free_space) - register relocatable_pointer *up_to_this_ptr; - POINTER free_space; -{ - register relocatable_pointer *this_ptr; - POINTER block_start = pointer_list->block; - POINTER block_end = up_to_this_ptr->block + up_to_this_ptr->size; - unsigned int total_size = block_end - block_start; - unsigned int offset = (int) (free_space - block_start); - - bcopy (block_start, free_space, total_size); - for (this_ptr = up_to_this_ptr; this_ptr; this_ptr = this_ptr->prev) - { - struct other_pointer *op = this_ptr->others; - - *this_ptr->location += offset; - this_ptr->block += offset; - - while (op != (struct other_pointer *) 0) - { - *op->location += offset; - op = op->next; - } - } - - /* Connect the head to the tail. */ - last_pointer->next = pointer_list; - pointer_list->prev = last_pointer; - - /* Disconnect */ - up_to_this_ptr->next->prev = REL_NIL; - pointer_list = up_to_this_ptr->next; - up_to_this_ptr->next = REL_NIL; - last_pointer = up_to_this_ptr; - - return total_size; /* of space relocated. */ -} - -/* Relocate the list elements from FROM_THIS_PTR to (and including) - the last to the zone beginning at FREE_SPACE, which is located - before any blocks. - - First copy all the data, then adjust the pointers and reorganize - the list. NOTE that this *only* works for contiguous blocks. */ - -static unsigned int -relocate_to_beginning (from_this_ptr, free_space) - register relocatable_pointer *from_this_ptr; - POINTER free_space; -{ - POINTER block_start = from_this_ptr->block; - POINTER block_end = last_pointer->block + last_pointer->size; - unsigned int total_size = (int) (block_end - block_start); - unsigned int offset = (int) (from_this_ptr->block - free_space); - register relocatable_pointer *this_ptr; - - bcopy (block_start, free_space, total_size); - for (this_ptr = from_this_ptr; this_ptr; this_ptr = this_ptr->next) - { - struct other_pointer *op = this_ptr->others; - - *this_ptr->location -= offset; - this_ptr->block -= offset; - - while (op != (struct other_pointer *) 0) - { - *op->location -= offset; - op = op->next; - } - } - - /* Connect the end to the beginning. */ - last_pointer->next = pointer_list; - pointer_list->prev = last_pointer; - - /* Disconnect and reset first and last. */ - from_this_ptr->prev->next = REL_NIL; - last_pointer = from_this_ptr->prev; - pointer_list = from_this_ptr; - pointer_list->prev = REL_NIL; - - return total_size; /* of space moved. */ -} - -/* Relocate any blocks neccessary, either upwards or downwards, - to obtain a space of SIZE bytes. Assumes we have at least one block. */ - -static unsigned int -relocate (size) - register int size; -{ - register relocatable_pointer *ptr; - register int got = 0; - - if (size > 0) /* Up: Relocate enough blocs to get SIZE. */ - { - register POINTER new_space; - - for (ptr = pointer_list; got < size && ptr; ptr = ptr->next) - got += ptr->size; - - if (ptr == REL_NIL) - ptr = last_pointer; - - new_space = get_more_space (size); - if (!new_space) - return 0; - - return (relocate_to_end (ptr, pointer_list->block + size)); - } - - if (size < 0) /* Down: relocate as many blocs as will - fit in SIZE bytes of space. */ - { - register POINTER to_zone; - unsigned int moved; - - for (ptr = last_pointer; got >= size && ptr; ptr = ptr->prev) - got -= ptr->size; - - if (ptr == REL_NIL) - ptr = pointer_list; - else - { - /* Back off one block to be <= size */ - got += ptr->size; - ptr = ptr->next; - } - - if (got >= size) - { - to_zone = virtual_break_value - size + got; - moved = relocate_to_beginning (ptr, to_zone); - if (moved) - return_space (moved); - - return moved; - } - - return 0; - } - - abort (); -} - -/* This function encapsulates `sbrk' to preserve the relocatable blocks. - It is called just like `sbrk'. When relocatable blocks are in use, - `malloc' must use this function instead of `sbrk'. */ - -POINTER -r_alloc_sbrk (size) - unsigned int size; -{ - POINTER new_zone; /* Start of the zone we will return. */ - -#if 0 - if (! r_alloc_in_use) - return (POINTER) sbrk (size); -#endif - - if (size == 0) - return virtual_break_value; - - if (size > 0) /* Get more space */ - { - register unsigned int space; - - if (pointer_list == REL_NIL) - { - POINTER space = get_more_space (size); - - virtual_break_value = real_break_value; - return space; - } - - new_zone = virtual_break_value; - - /* Check if there is a hole just before the buffer zone. */ - if (holes && r_alloc_holes[0].address == virtual_break_value) - { - if (r_alloc_holes[0].size > size) - { - /* Adjust the hole size. */ - r_alloc_holes[0].size -= size; - r_alloc_holes[0].address += size; - virtual_break_value += size; - - return new_zone; - } - - if (r_alloc_holes[0].size == size) - { - virtual_break_value += size; - delete_hole (0); - - return new_zone; - } - - /* Adjust the size requested by space - already available in this hole. */ - size -= r_alloc_holes[0].size; - virtual_break_value += r_alloc_holes[0].size; - delete_hole (0); - } - - space = relocate (size); - if (!space) - return (POINTER) -1; - -#ifdef REL_ALLOC_SAVE_SPACE - move_blocks_downward -#else - bzero (new_zone, space); - if (space > size) - note_hole (new_zone + size, space - size); -#endif /* REL_ALLOC_SAVE_SPACE */ - - virtual_break_value += size; - return new_zone; - } - else /* Return space to system */ - { - int moved; - int left_over; - POINTER old_break_value; - - if (pointer_list == REL_NIL) - { - POINTER space = return_space (-size); - virtual_break_value = real_break_value; - - return space; - } - - if (holes && r_alloc_holes[0].address == virtual_break_value) - { - size -= r_alloc_holes[0].size; - delete_hole (0); - } - - moved = relocate (size); - old_break_value = virtual_break_value; - - if (!moved) - return (POINTER) -1; - - left_over = moved + size; - virtual_break_value += size; - - if (left_over) - { -#ifdef REL_ALLOC_SAVE_SPACE - move_blocks_downward -#else - bzero (virtual_break_value, left_over); - note_hole (virtual_break_value, left_over); -#endif /* not REL_ALLOC_SAVE_SPACE */ - } - - return old_break_value; - } -} - -/* For debugging */ - -#include <stdio.h> - -void -memory_trace () -{ - relocatable_pointer *ptr; - int i; - - fprintf (stderr, "virtual: 0x%x\n real: 0x%x\n true: 0x%x\n\n", - virtual_break_value, real_break_value, true_break_value); - fprintf (stderr, "Blocks:\n"); - for (ptr = pointer_list; ptr; ptr = ptr->next) - { - fprintf (stderr, " address: 0x%x\n", ptr->block); - fprintf (stderr, " size: 0x%x\n", ptr->size); - if (ptr->others) - { - struct other_pointer *op = ptr->others; - fprintf (stderr, " others:", ptr->size); - while (op) - { - fprintf (stderr, " 0x%x", op->location); - op = op->next; - } - fprintf (stderr, "\n"); - } - } - - if (holes) - { - fprintf (stderr, "\nHoles:\n"); - for (i = 0; i < holes; i++) - { - fprintf (stderr, " address: 0x%x\n", r_alloc_holes[i].address); - fprintf (stderr, " size: 0x%x\n", r_alloc_holes[i].size); - } - } - - fprintf (stderr, "\n\n"); -}
--- a/src/=sol2-2.h Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -/* casper@fwi.uva.nl says this file is not needed - and sol2.h should work. */ - -#include "sol2.h" - -/* Take care of libucb.a as well as X Windows. */ -#undef LD_SWITCH_SYSTEM -#ifndef __GNUC__ -#define LD_SWITCH_SYSTEM -R/usr/openwin/lib:/usr/ucblib -#else /* GCC */ -#define LD_SWITCH_SYSTEM -Xlinker -R/usr/openwin/lib:/usr/ucblib -#endif /* GCC */ - -/* Link with libucb.a. */ -#ifdef LIB_STANDARD -#undef LIB_STANDARD -#define LIB_STANDARD -lc -L/usr/ucblib -lucb -#endif
--- a/src/=unexelf1.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,952 +0,0 @@ -/* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992 - 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. - -In other words, you are welcome to use, share and improve this program. -You are forbidden to forbid anyone else to use, share and improve -what you give them. Help stamp out software-hoarding! */ - - -/* - * unexec.c - Convert a running program into an a.out file. - * - * Author: Spencer W. Thomas - * Computer Science Dept. - * University of Utah - * Date: Tue Mar 2 1982 - * Modified heavily since then. - * - * Synopsis: - * unexec (new_name, a_name, data_start, bss_start, entry_address) - * char *new_name, *a_name; - * unsigned data_start, bss_start, entry_address; - * - * Takes a snapshot of the program and makes an a.out format file in the - * file named by the string argument new_name. - * If a_name is non-NULL, the symbol table will be taken from the given file. - * On some machines, an existing a_name file is required. - * - * The boundaries within the a.out file may be adjusted with the data_start - * and bss_start arguments. Either or both may be given as 0 for defaults. - * - * Data_start gives the boundary between the text segment and the data - * segment of the program. The text segment can contain shared, read-only - * program code and literal data, while the data segment is always unshared - * and unprotected. Data_start gives the lowest unprotected address. - * The value you specify may be rounded down to a suitable boundary - * as required by the machine you are using. - * - * Specifying zero for data_start means the boundary between text and data - * should not be the same as when the program was loaded. - * If NO_REMAP is defined, the argument data_start is ignored and the - * segment boundaries are never changed. - * - * Bss_start indicates how much of the data segment is to be saved in the - * a.out file and restored when the program is executed. It gives the lowest - * unsaved address, and is rounded up to a page boundary. The default when 0 - * is given assumes that the entire data segment is to be stored, including - * the previous data and bss as well as any additional storage allocated with - * break (2). - * - * The new file is set up to start at entry_address. - * - * If you make improvements I'd like to get them too. - * harpo!utah-cs!thomas, thomas@Utah-20 - * - */ - -/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. - * ELF support added. - * - * Basic theory: the data space of the running process needs to be - * dumped to the output file. Normally we would just enlarge the size - * of .data, scooting everything down. But we can't do that in ELF, - * because there is often something between the .data space and the - * .bss space. - * - * In the temacs dump below, notice that the Global Offset Table - * (.got) and the Dynamic link data (.dynamic) come between .data1 and - * .bss. It does not work to overlap .data with these fields. - * - * The solution is to create a new .data segment. This segment is - * filled with data from the current process. Since the contents of - * various sections refer to sections by index, the new .data segment - * is made the last in the table to avoid changing any existing index. - - * This is an example of how the section headers are changed. "Addr" - * is a process virtual address. "Offset" is a file offset. - -raid:/nfs/raid/src/dist-18.56/src> dump -h temacs - -temacs: - - **** SECTION HEADER TABLE **** -[No] Type Flags Addr Offset Size Name - Link Info Adralgn Entsize - -[1] 1 2 0x80480d4 0xd4 0x13 .interp - 0 0 0x1 0 - -[2] 5 2 0x80480e8 0xe8 0x388 .hash - 3 0 0x4 0x4 - -[3] 11 2 0x8048470 0x470 0x7f0 .dynsym - 4 1 0x4 0x10 - -[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr - 0 0 0x1 0 - -[5] 9 2 0x8049010 0x1010 0x338 .rel.plt - 3 7 0x4 0x8 - -[6] 1 6 0x8049348 0x1348 0x3 .init - 0 0 0x4 0 - -[7] 1 6 0x804934c 0x134c 0x680 .plt - 0 0 0x4 0x4 - -[8] 1 6 0x80499cc 0x19cc 0x3c56f .text - 0 0 0x4 0 - -[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini - 0 0 0x4 0 - -[10] 1 2 0x8085f40 0x3df40 0x69c .rodata - 0 0 0x4 0 - -[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 - 0 0 0x4 0 - -[12] 1 3 0x8088330 0x3f330 0x20afc .data - 0 0 0x4 0 - -[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 - 0 0 0x4 0 - -[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got - 0 0 0x4 0x4 - -[15] 6 3 0x80a9874 0x60874 0x80 .dynamic - 4 0 0x4 0x8 - -[16] 8 3 0x80a98f4 0x608f4 0x449c .bss - 0 0 0x4 0 - -[17] 2 0 0 0x608f4 0x9b90 .symtab - 18 371 0x4 0x10 - -[18] 3 0 0 0x6a484 0x8526 .strtab - 0 0 0x1 0 - -[19] 3 0 0 0x729aa 0x93 .shstrtab - 0 0 0x1 0 - -[20] 1 0 0 0x72a3d 0x68b7 .comment - 0 0 0x1 0 - -raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs - -xemacs: - - **** SECTION HEADER TABLE **** -[No] Type Flags Addr Offset Size Name - Link Info Adralgn Entsize - -[1] 1 2 0x80480d4 0xd4 0x13 .interp - 0 0 0x1 0 - -[2] 5 2 0x80480e8 0xe8 0x388 .hash - 3 0 0x4 0x4 - -[3] 11 2 0x8048470 0x470 0x7f0 .dynsym - 4 1 0x4 0x10 - -[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr - 0 0 0x1 0 - -[5] 9 2 0x8049010 0x1010 0x338 .rel.plt - 3 7 0x4 0x8 - -[6] 1 6 0x8049348 0x1348 0x3 .init - 0 0 0x4 0 - -[7] 1 6 0x804934c 0x134c 0x680 .plt - 0 0 0x4 0x4 - -[8] 1 6 0x80499cc 0x19cc 0x3c56f .text - 0 0 0x4 0 - -[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini - 0 0 0x4 0 - -[10] 1 2 0x8085f40 0x3df40 0x69c .rodata - 0 0 0x4 0 - -[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 - 0 0 0x4 0 - -[12] 1 3 0x8088330 0x3f330 0x20afc .data - 0 0 0x4 0 - -[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 - 0 0 0x4 0 - -[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got - 0 0 0x4 0x4 - -[15] 6 3 0x80a9874 0x60874 0x80 .dynamic - 4 0 0x4 0x8 - -[16] 8 3 0x80c6800 0x7d800 0 .bss - 0 0 0x4 0 - -[17] 2 0 0 0x7d800 0x9b90 .symtab - 18 371 0x4 0x10 - -[18] 3 0 0 0x87390 0x8526 .strtab - 0 0 0x1 0 - -[19] 3 0 0 0x8f8b6 0x93 .shstrtab - 0 0 0x1 0 - -[20] 1 0 0 0x8f949 0x68b7 .comment - 0 0 0x1 0 - -[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data - 0 0 0x4 0 - - * This is an example of how the file header is changed. "Shoff" is - * the section header offset within the file. Since that table is - * after the new .data section, it is moved. "Shnum" is the number of - * sections, which we increment. - * - * "Phoff" is the file offset to the program header. "Phentsize" and - * "Shentsz" are the program and section header entries sizes respectively. - * These can be larger than the apparent struct sizes. - -raid:/nfs/raid/src/dist-18.56/src> dump -f temacs - -temacs: - - **** ELF HEADER **** -Class Data Type Machine Version -Entry Phoff Shoff Flags Ehsize -Phentsize Phnum Shentsz Shnum Shstrndx - -1 1 2 3 1 -0x80499cc 0x34 0x792f4 0 0x34 -0x20 5 0x28 21 19 - -raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs - -xemacs: - - **** ELF HEADER **** -Class Data Type Machine Version -Entry Phoff Shoff Flags Ehsize -Phentsize Phnum Shentsz Shnum Shstrndx - -1 1 2 3 1 -0x80499cc 0x34 0x96200 0 0x34 -0x20 5 0x28 22 19 - - * These are the program headers. "Offset" is the file offset to the - * segment. "Vaddr" is the memory load address. "Filesz" is the - * segment size as it appears in the file, and "Memsz" is the size in - * memory. Below, the third segment is the code and the fourth is the - * data: the difference between Filesz and Memsz is .bss - -raid:/nfs/raid/src/dist-18.56/src> dump -o temacs - -temacs: - ***** PROGRAM EXECUTION HEADER ***** -Type Offset Vaddr Paddr -Filesz Memsz Flags Align - -6 0x34 0x8048034 0 -0xa0 0xa0 5 0 - -3 0xd4 0 0 -0x13 0 4 0 - -1 0x34 0x8048034 0 -0x3f2f9 0x3f2f9 5 0x1000 - -1 0x3f330 0x8088330 0 -0x215c4 0x25a60 7 0x1000 - -2 0x60874 0x80a9874 0 -0x80 0 7 0 - -raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs - -xemacs: - ***** PROGRAM EXECUTION HEADER ***** -Type Offset Vaddr Paddr -Filesz Memsz Flags Align - -6 0x34 0x8048034 0 -0xa0 0xa0 5 0 - -3 0xd4 0 0 -0x13 0 4 0 - -1 0x34 0x8048034 0 -0x3f2f9 0x3f2f9 5 0x1000 - -1 0x3f330 0x8088330 0 -0x3e4d0 0x3e4d0 7 0x1000 - -2 0x60874 0x80a9874 0 -0x80 0 7 0 - - - */ - -/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. - * - * The above mechanism does not work if the unexeced ELF file is being - * re-layout by other applications (such as `strip'). All the applications - * that re-layout the internal of ELF will layout all sections in ascending - * order of their file offsets. After the re-layout, the data2 section will - * still be the LAST section in the section header vector, but its file offset - * is now being pushed far away down, and causes part of it not to be mapped - * in (ie. not covered by the load segment entry in PHDR vector), therefore - * causes the new binary to fail. - * - * The solution is to modify the unexec algorithm to insert the new data2 - * section header right before the new bss section header, so their file - * offsets will be in the ascending order. Since some of the section's (all - * sections AFTER the bss section) indexes are now changed, we also need to - * modify some fields to make them point to the right sections. This is done - * by macro PATCH_INDEX. All the fields that need to be patched are: - * - * 1. ELF header e_shstrndx field. - * 2. section header sh_link and sh_info field. - * 3. symbol table entry st_shndx field. - * - * The above example now should look like: - - **** SECTION HEADER TABLE **** -[No] Type Flags Addr Offset Size Name - Link Info Adralgn Entsize - -[1] 1 2 0x80480d4 0xd4 0x13 .interp - 0 0 0x1 0 - -[2] 5 2 0x80480e8 0xe8 0x388 .hash - 3 0 0x4 0x4 - -[3] 11 2 0x8048470 0x470 0x7f0 .dynsym - 4 1 0x4 0x10 - -[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr - 0 0 0x1 0 - -[5] 9 2 0x8049010 0x1010 0x338 .rel.plt - 3 7 0x4 0x8 - -[6] 1 6 0x8049348 0x1348 0x3 .init - 0 0 0x4 0 - -[7] 1 6 0x804934c 0x134c 0x680 .plt - 0 0 0x4 0x4 - -[8] 1 6 0x80499cc 0x19cc 0x3c56f .text - 0 0 0x4 0 - -[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini - 0 0 0x4 0 - -[10] 1 2 0x8085f40 0x3df40 0x69c .rodata - 0 0 0x4 0 - -[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 - 0 0 0x4 0 - -[12] 1 3 0x8088330 0x3f330 0x20afc .data - 0 0 0x4 0 - -[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 - 0 0 0x4 0 - -[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got - 0 0 0x4 0x4 - -[15] 6 3 0x80a9874 0x60874 0x80 .dynamic - 4 0 0x4 0x8 - -[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data - 0 0 0x4 0 - -[17] 8 3 0x80c6800 0x7d800 0 .bss - 0 0 0x4 0 - -[18] 2 0 0 0x7d800 0x9b90 .symtab - 19 371 0x4 0x10 - -[19] 3 0 0 0x87390 0x8526 .strtab - 0 0 0x1 0 - -[20] 3 0 0 0x8f8b6 0x93 .shstrtab - 0 0 0x1 0 - -[21] 1 0 0 0x8f949 0x68b7 .comment - 0 0 0x1 0 - - */ - -#include <sys/types.h> -#include <stdio.h> -#include <sys/stat.h> -#include <memory.h> -#include <string.h> -#include <errno.h> -#include <unistd.h> -#include <fcntl.h> -#include <elf.h> -#include <sys/mman.h> - -#ifdef __alpha__ -# include <sym.h> /* get COFF debugging symbol table declaration */ -#endif - -#if __GNU_LIBRARY__ - 0 >= 6 -# include <link.h> /* get ElfW etc */ -#endif - -#ifndef ElfW -# ifdef __STDC__ -# define ElfW(type) Elf32_##type -# else -# define ElfW(type) Elf32_/**/type -# endif -#endif - -#ifndef emacs -#define fatal(a, b, c) fprintf (stderr, a, b, c), exit (1) -#else -#include <config.h> -extern void fatal (char *, ...); -#endif - -#ifndef ELF_BSS_SECTION_NAME -#define ELF_BSS_SECTION_NAME ".bss" -#endif - -/* Get the address of a particular section or program header entry, - * accounting for the size of the entries. - */ -/* - On PPC Reference Platform running Solaris 2.5.1 - the plt section is also of type NOBI like the bss section. - (not really stored) and therefore sections after the bss - section start at the plt offset. The plt section is always - the one just before the bss section. - Thus, we modify the test from - if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) - to - if (NEW_SECTION_H (nn).sh_offset >= - OLD_SECTION_H (old_bss_index-1).sh_offset) - This is just a hack. We should put the new data section - before the .plt section. - And we should not have this routine at all but use - the libelf library to read the old file and create the new - file. - The changed code is minimal and depends on prep set in m/prep.h - Erik Deumens - Quantum Theory Project - University of Florida - deumens@qtp.ufl.edu - Apr 23, 1996 - */ - -#define OLD_SECTION_H(n) \ - (*(ElfW(Shdr) *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) -#define NEW_SECTION_H(n) \ - (*(ElfW(Shdr) *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) -#define OLD_PROGRAM_H(n) \ - (*(ElfW(Phdr) *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) -#define NEW_PROGRAM_H(n) \ - (*(ElfW(Phdr) *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) - -#define PATCH_INDEX(n) \ - do { \ - if ((int) (n) >= old_bss_index) \ - (n)++; } while (0) -typedef unsigned char byte; - -/* Round X up to a multiple of Y. */ - -int -round_up (x, y) - int x, y; -{ - int rem = x % y; - if (rem == 0) - return x; - return x - rem + y; -} - -/* **************************************************************** - * unexec - * - * driving logic. - * - * In ELF, this works by replacing the old .bss section with a new - * .data section, and inserting an empty .bss immediately afterwards. - * - */ -void -unexec (new_name, old_name, data_start, bss_start, entry_address) - char *new_name, *old_name; - unsigned data_start, bss_start, entry_address; -{ - int new_file, old_file, new_file_size; - - /* Pointers to the base of the image of the two files. */ - caddr_t old_base, new_base; - - /* Pointers to the file, program and section headers for the old and new - * files. - */ - ElfW(Ehdr) *old_file_h, *new_file_h; - ElfW(Phdr) *old_program_h, *new_program_h; - ElfW(Shdr) *old_section_h, *new_section_h; - - /* Point to the section name table in the old file */ - char *old_section_names; - - ElfW(Addr) old_bss_addr, new_bss_addr; - ElfW(Word) old_bss_size, new_data2_size; - ElfW(Off) new_data2_offset; - ElfW(Addr) new_data2_addr; - - int n, nn, old_bss_index, old_data_index, new_data2_index; - struct stat stat_buf; - - /* Open the old file & map it into the address space. */ - - old_file = open (old_name, O_RDONLY); - - if (old_file < 0) - fatal ("Can't open %s for reading: errno %d\n", old_name, errno); - - if (fstat (old_file, &stat_buf) == -1) - fatal ("Can't fstat (%s): errno %d\n", old_name, errno); - - old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0); - - if (old_base == (caddr_t) -1) - fatal ("Can't mmap (%s): errno %d\n", old_name, errno); - -#ifdef DEBUG - fprintf (stderr, "mmap (%s, %x) -> %x\n", old_name, stat_buf.st_size, - old_base); -#endif - - /* Get pointers to headers & section names */ - - old_file_h = (ElfW(Ehdr) *) old_base; - old_program_h = (ElfW(Phdr) *) ((byte *) old_base + old_file_h->e_phoff); - old_section_h = (ElfW(Shdr) *) ((byte *) old_base + old_file_h->e_shoff); - old_section_names = (char *) old_base - + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; - - /* Find the old .bss section. Figure out parameters of the new - * data2 and bss sections. - */ - - for (old_bss_index = 1; old_bss_index < (int) old_file_h->e_shnum; - old_bss_index++) - { -#ifdef DEBUG - fprintf (stderr, "Looking for .bss - found %s\n", - old_section_names + OLD_SECTION_H (old_bss_index).sh_name); -#endif - if (!strcmp (old_section_names + OLD_SECTION_H (old_bss_index).sh_name, - ELF_BSS_SECTION_NAME)) - break; - } - if (old_bss_index == old_file_h->e_shnum) - fatal ("Can't find .bss in %s.\n", old_name, 0); - - old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; - old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; -#if defined(emacs) || !defined(DEBUG) - new_bss_addr = (ElfW(Addr)) sbrk (0); -#else - new_bss_addr = old_bss_addr + old_bss_size + 0x1234; -#endif - new_data2_addr = old_bss_addr; - new_data2_size = new_bss_addr - old_bss_addr; - new_data2_offset = OLD_SECTION_H (old_bss_index).sh_offset; - -#ifdef DEBUG - fprintf (stderr, "old_bss_index %d\n", old_bss_index); - fprintf (stderr, "old_bss_addr %x\n", old_bss_addr); - fprintf (stderr, "old_bss_size %x\n", old_bss_size); - fprintf (stderr, "new_bss_addr %x\n", new_bss_addr); - fprintf (stderr, "new_data2_addr %x\n", new_data2_addr); - fprintf (stderr, "new_data2_size %x\n", new_data2_size); - fprintf (stderr, "new_data2_offset %x\n", new_data2_offset); -#endif - - if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) - fatal (".bss shrank when undumping???\n", 0, 0); - - /* Set the output file to the right size and mmap it. Set - * pointers to various interesting objects. stat_buf still has - * old_file data. - */ - - new_file = open (new_name, O_RDWR | O_CREAT, 0666); - if (new_file < 0) - fatal ("Can't creat (%s): errno %d\n", new_name, errno); - - new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size; - - if (ftruncate (new_file, new_file_size)) - fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); - -#ifdef UNEXEC_USE_MAP_PRIVATE - new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_PRIVATE, - new_file, 0); -#else - new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED, - new_file, 0); -#endif - - if (new_base == (caddr_t) -1) - fatal ("Can't mmap (%s): errno %d\n", new_name, errno); - - new_file_h = (ElfW(Ehdr) *) new_base; - new_program_h = (ElfW(Phdr) *) ((byte *) new_base + old_file_h->e_phoff); - new_section_h = (ElfW(Shdr) *) - ((byte *) new_base + old_file_h->e_shoff + new_data2_size); - - /* Make our new file, program and section headers as copies of the - * originals. - */ - - memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); - memcpy (new_program_h, old_program_h, - old_file_h->e_phnum * old_file_h->e_phentsize); - - /* Modify the e_shstrndx if necessary. */ - PATCH_INDEX (new_file_h->e_shstrndx); - - /* Fix up file header. We'll add one section. Section header is - * further away now. - */ - - new_file_h->e_shoff += new_data2_size; - new_file_h->e_shnum += 1; - -#ifdef DEBUG - fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff); - fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum); - fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff); - fprintf (stderr, "New section count %d\n", new_file_h->e_shnum); -#endif - - /* Fix up a new program header. Extend the writable data segment so - * that the bss area is covered too. Find that segment by looking - * for a segment that ends just before the .bss area. Make sure - * that no segments are above the new .data2. Put a loop at the end - * to adjust the offset and address of any segment that is above - * data2, just in case we decide to allow this later. - */ - - for (n = new_file_h->e_phnum - 1; n >= 0; n--) - { - /* Compute maximum of all requirements for alignment of section. */ - int alignment = (NEW_PROGRAM_H (n)).p_align; - if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) - alignment = OLD_SECTION_H (old_bss_index).sh_addralign; - - if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr) - fatal ("Program segment above .bss in %s\n", old_name, 0); - - if (NEW_PROGRAM_H (n).p_type == PT_LOAD - && (round_up ((NEW_PROGRAM_H (n)).p_vaddr - + (NEW_PROGRAM_H (n)).p_filesz, - alignment) - == round_up (old_bss_addr, alignment))) - break; - } - if (n < 0) - fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0); - - NEW_PROGRAM_H (n).p_filesz += new_data2_size; - NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; - -#if 0 /* Maybe allow section after data2 - does this ever happen? */ - for (n = new_file_h->e_phnum - 1; n >= 0; n--) - { - if (NEW_PROGRAM_H (n).p_vaddr - && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) - NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size; - - if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) - NEW_PROGRAM_H (n).p_offset += new_data2_size; - } -#endif - - /* Fix up section headers based on new .data2 section. Any section - * whose offset or virtual address is after the new .data2 section - * gets its value adjusted. .bss size becomes zero and new address - * is set. data2 section header gets added by copying the existing - * .data header and modifying the offset, address and size. - */ - for (old_data_index = 1; old_data_index < (int) old_file_h->e_shnum; - old_data_index++) - if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, - ".data")) - break; - if (old_data_index == old_file_h->e_shnum) - fatal ("Can't find .data in %s.\n", old_name, 0); - - /* Walk through all section headers, insert the new data2 section right - before the new bss section. */ - for (n = 1, nn = 1; n < (int) old_file_h->e_shnum; n++, nn++) - { - caddr_t src; - /* If it is bss section, insert the new data2 section before it. */ - if (n == old_bss_index) - { - /* Steal the data section header for this data2 section. */ - memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), - new_file_h->e_shentsize); - - NEW_SECTION_H (nn).sh_addr = new_data2_addr; - NEW_SECTION_H (nn).sh_offset = new_data2_offset; - NEW_SECTION_H (nn).sh_size = new_data2_size; - /* Use the bss section's alignment. This will assure that the - new data2 section always be placed in the same spot as the old - bss section by any other application. */ - NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; - - /* Now copy over what we have in the memory now. */ - memcpy (NEW_SECTION_H (nn).sh_offset + new_base, - (caddr_t) OLD_SECTION_H (n).sh_addr, - new_data2_size); - nn++; - } - - memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), - old_file_h->e_shentsize); - - /* The new bss section's size is zero, and its file offset and virtual - address should be off by NEW_DATA2_SIZE. */ - if (n == old_bss_index) - { - /* NN should be `old_bss_index + 1' at this point. */ - NEW_SECTION_H (nn).sh_offset += new_data2_size; - NEW_SECTION_H (nn).sh_addr += new_data2_size; - /* Let the new bss section address alignment be the same as the - section address alignment followed the old bss section, so - this section will be placed in exactly the same place. */ - NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; - NEW_SECTION_H (nn).sh_size = 0; - } - else - { - /* Any section that was original placed AFTER the bss - section should now be off by NEW_DATA2_SIZE. */ -#ifdef SOLARIS_POWERPC - /* On PPC Reference Platform running Solaris 2.5.1 - the plt section is also of type NOBI like the bss section. - (not really stored) and therefore sections after the bss - section start at the plt offset. The plt section is always - the one just before the bss section. - It would be better to put the new data section before - the .plt section, or use libelf instead. - Erik Deumens, deumens@qtp.ufl.edu. */ - if (NEW_SECTION_H (nn).sh_offset - >= OLD_SECTION_H (old_bss_index-1).sh_offset) - NEW_SECTION_H (nn).sh_offset += new_data2_size; -#else - if (round_up (NEW_SECTION_H (nn).sh_offset, - OLD_SECTION_H (old_bss_index).sh_addralign) - >= new_data2_offset) - NEW_SECTION_H (nn).sh_offset += new_data2_size; -#endif - /* Any section that was originally placed after the section - header table should now be off by the size of one section - header table entry. */ - if (NEW_SECTION_H (nn).sh_offset > new_file_h->e_shoff) - NEW_SECTION_H (nn).sh_offset += new_file_h->e_shentsize; - } - - /* If any section hdr refers to the section after the new .data - section, make it refer to next one because we have inserted - a new section in between. */ - - PATCH_INDEX (NEW_SECTION_H (nn).sh_link); - /* For symbol tables, info is a symbol table index, - so don't change it. */ - if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB - && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) - PATCH_INDEX (NEW_SECTION_H (nn).sh_info); - - /* Now, start to copy the content of sections. */ - if (NEW_SECTION_H (nn).sh_type == SHT_NULL - || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) - continue; - - /* Write out the sections. .data and .data1 (and data2, called - ".data" in the strings table) get copied from the current process - instead of the old file. */ - if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data") - || !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name), - ".data1")) - src = (caddr_t) OLD_SECTION_H (n).sh_addr; - else - src = old_base + OLD_SECTION_H (n).sh_offset; - - memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, - NEW_SECTION_H (nn).sh_size); - -#ifdef __alpha__ - /* Update Alpha COFF symbol table: */ - if (strcmp (old_section_names + OLD_SECTION_H (n).sh_name, ".mdebug") - == 0) - { - pHDRR symhdr = (pHDRR) (NEW_SECTION_H (nn).sh_offset + new_base); - - symhdr->cbLineOffset += new_data2_size; - symhdr->cbDnOffset += new_data2_size; - symhdr->cbPdOffset += new_data2_size; - symhdr->cbSymOffset += new_data2_size; - symhdr->cbOptOffset += new_data2_size; - symhdr->cbAuxOffset += new_data2_size; - symhdr->cbSsOffset += new_data2_size; - symhdr->cbSsExtOffset += new_data2_size; - symhdr->cbFdOffset += new_data2_size; - symhdr->cbRfdOffset += new_data2_size; - symhdr->cbExtOffset += new_data2_size; - } -#endif /* __alpha__ */ - - /* If it is the symbol table, its st_shndx field needs to be patched. */ - if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB - || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) - { - ElfW(Shdr) *spt = &NEW_SECTION_H (nn); - unsigned int num = spt->sh_size / spt->sh_entsize; - ElfW(Sym) * sym = (ElfW(Sym) *) (NEW_SECTION_H (nn).sh_offset + - new_base); - for (; num--; sym++) - { - if ((sym->st_shndx == SHN_UNDEF) - || (sym->st_shndx == SHN_ABS) - || (sym->st_shndx == SHN_COMMON)) - continue; - - PATCH_INDEX (sym->st_shndx); - } - } - } - - /* Update the symbol values of _edata and _end. */ - for (n = new_file_h->e_shnum - 1; n; n--) - { - byte *symnames; - ElfW(Sym) *symp, *symendp; - - if (NEW_SECTION_H (n).sh_type != SHT_DYNSYM - && NEW_SECTION_H (n).sh_type != SHT_SYMTAB) - continue; - - symnames = ((byte *) new_base - + NEW_SECTION_H (NEW_SECTION_H (n).sh_link).sh_offset); - symp = (ElfW(Sym) *) (NEW_SECTION_H (n).sh_offset + new_base); - symendp = (ElfW(Sym) *) ((byte *)symp + NEW_SECTION_H (n).sh_size); - - for (; symp < symendp; symp ++) - if (strcmp ((char *) (symnames + symp->st_name), "_end") == 0 - || strcmp ((char *) (symnames + symp->st_name), "_edata") == 0) - memcpy (&symp->st_value, &new_bss_addr, sizeof (new_bss_addr)); - } - - /* This loop seeks out relocation sections for the data section, so - that it can undo relocations performed by the runtime linker. */ - for (n = new_file_h->e_shnum - 1; n; n--) - { - ElfW(Shdr) section = NEW_SECTION_H (n); - switch (section.sh_type) { - default: - break; - case SHT_REL: - case SHT_RELA: - /* This code handles two different size structs, but there should - be no harm in that provided that r_offset is always the first - member. */ - nn = section.sh_info; - if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data") - || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), - ".data1")) - { - ElfW(Addr) offset = NEW_SECTION_H (nn).sh_addr - - NEW_SECTION_H (nn).sh_offset; - caddr_t reloc = old_base + section.sh_offset, end; - for (end = reloc + section.sh_size; reloc < end; - reloc += section.sh_entsize) - { - ElfW(Addr) addr = ((ElfW(Rel) *) reloc)->r_offset - offset; -#ifdef __alpha__ - /* The Alpha ELF binutils currently have a bug that - sometimes results in relocs that contain all - zeroes. Work around this for now... */ - if (((ElfW(Rel) *) reloc)->r_offset == 0) - continue; -#endif - memcpy (new_base + addr, old_base + addr, sizeof(ElfW(Addr))); - } - } - break; - } - } - -#ifdef UNEXEC_USE_MAP_PRIVATE - if (lseek (new_file, 0, SEEK_SET) == -1) - fatal ("Can't rewind (%s): errno %d\n", new_name, errno); - - if (write (new_file, new_base, new_file_size) != new_file_size) - fatal ("Can't write (%s): errno %d\n", new_name, errno); -#endif - - /* Close the files and make the new file executable. */ - - if (close (old_file)) - fatal ("Can't close (%s): errno %d\n", old_name, errno); - - if (close (new_file)) - fatal ("Can't close (%s): errno %d\n", new_name, errno); - - if (stat (new_name, &stat_buf) == -1) - fatal ("Can't stat (%s): errno %d\n", new_name, errno); - - n = umask (777); - umask (n); - stat_buf.st_mode |= 0111 & ~n; - if (chmod (new_name, stat_buf.st_mode) == -1) - fatal ("Can't chmod (%s): errno %d\n", new_name, errno); -}
--- a/src/=unexsgi.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,900 +0,0 @@ -/* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992 - 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. - -In other words, you are welcome to use, share and improve this program. -You are forbidden to forbid anyone else to use, share and improve -what you give them. Help stamp out software-hoarding! */ - - -/* - * unexec.c - Convert a running program into an a.out file. - * - * Author: Spencer W. Thomas - * Computer Science Dept. - * University of Utah - * Date: Tue Mar 2 1982 - * Modified heavily since then. - * - * Synopsis: - * unexec (new_name, a_name, data_start, bss_start, entry_address) - * char *new_name, *a_name; - * unsigned data_start, bss_start, entry_address; - * - * Takes a snapshot of the program and makes an a.out format file in the - * file named by the string argument new_name. - * If a_name is non-NULL, the symbol table will be taken from the given file. - * On some machines, an existing a_name file is required. - * - * The boundaries within the a.out file may be adjusted with the data_start - * and bss_start arguments. Either or both may be given as 0 for defaults. - * - * Data_start gives the boundary between the text segment and the data - * segment of the program. The text segment can contain shared, read-only - * program code and literal data, while the data segment is always unshared - * and unprotected. Data_start gives the lowest unprotected address. - * The value you specify may be rounded down to a suitable boundary - * as required by the machine you are using. - * - * Specifying zero for data_start means the boundary between text and data - * should not be the same as when the program was loaded. - * If NO_REMAP is defined, the argument data_start is ignored and the - * segment boundaries are never changed. - * - * Bss_start indicates how much of the data segment is to be saved in the - * a.out file and restored when the program is executed. It gives the lowest - * unsaved address, and is rounded up to a page boundary. The default when 0 - * is given assumes that the entire data segment is to be stored, including - * the previous data and bss as well as any additional storage allocated with - * break (2). - * - * The new file is set up to start at entry_address. - * - * If you make improvements I'd like to get them too. - * harpo!utah-cs!thomas, thomas@Utah-20 - * - */ - -/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. - * ELF support added. - * - * Basic theory: the data space of the running process needs to be - * dumped to the output file. Normally we would just enlarge the size - * of .data, scooting everything down. But we can't do that in ELF, - * because there is often something between the .data space and the - * .bss space. - * - * In the temacs dump below, notice that the Global Offset Table - * (.got) and the Dynamic link data (.dynamic) come between .data1 and - * .bss. It does not work to overlap .data with these fields. - * - * The solution is to create a new .data segment. This segment is - * filled with data from the current process. Since the contents of - * various sections refer to sections by index, the new .data segment - * is made the last in the table to avoid changing any existing index. - - * This is an example of how the section headers are changed. "Addr" - * is a process virtual address. "Offset" is a file offset. - -raid:/nfs/raid/src/dist-18.56/src> dump -h temacs - -temacs: - - **** SECTION HEADER TABLE **** -[No] Type Flags Addr Offset Size Name - Link Info Adralgn Entsize - -[1] 1 2 0x80480d4 0xd4 0x13 .interp - 0 0 0x1 0 - -[2] 5 2 0x80480e8 0xe8 0x388 .hash - 3 0 0x4 0x4 - -[3] 11 2 0x8048470 0x470 0x7f0 .dynsym - 4 1 0x4 0x10 - -[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr - 0 0 0x1 0 - -[5] 9 2 0x8049010 0x1010 0x338 .rel.plt - 3 7 0x4 0x8 - -[6] 1 6 0x8049348 0x1348 0x3 .init - 0 0 0x4 0 - -[7] 1 6 0x804934c 0x134c 0x680 .plt - 0 0 0x4 0x4 - -[8] 1 6 0x80499cc 0x19cc 0x3c56f .text - 0 0 0x4 0 - -[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini - 0 0 0x4 0 - -[10] 1 2 0x8085f40 0x3df40 0x69c .rodata - 0 0 0x4 0 - -[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 - 0 0 0x4 0 - -[12] 1 3 0x8088330 0x3f330 0x20afc .data - 0 0 0x4 0 - -[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 - 0 0 0x4 0 - -[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got - 0 0 0x4 0x4 - -[15] 6 3 0x80a9874 0x60874 0x80 .dynamic - 4 0 0x4 0x8 - -[16] 8 3 0x80a98f4 0x608f4 0x449c .bss - 0 0 0x4 0 - -[17] 2 0 0 0x608f4 0x9b90 .symtab - 18 371 0x4 0x10 - -[18] 3 0 0 0x6a484 0x8526 .strtab - 0 0 0x1 0 - -[19] 3 0 0 0x729aa 0x93 .shstrtab - 0 0 0x1 0 - -[20] 1 0 0 0x72a3d 0x68b7 .comment - 0 0 0x1 0 - -raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs - -xemacs: - - **** SECTION HEADER TABLE **** -[No] Type Flags Addr Offset Size Name - Link Info Adralgn Entsize - -[1] 1 2 0x80480d4 0xd4 0x13 .interp - 0 0 0x1 0 - -[2] 5 2 0x80480e8 0xe8 0x388 .hash - 3 0 0x4 0x4 - -[3] 11 2 0x8048470 0x470 0x7f0 .dynsym - 4 1 0x4 0x10 - -[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr - 0 0 0x1 0 - -[5] 9 2 0x8049010 0x1010 0x338 .rel.plt - 3 7 0x4 0x8 - -[6] 1 6 0x8049348 0x1348 0x3 .init - 0 0 0x4 0 - -[7] 1 6 0x804934c 0x134c 0x680 .plt - 0 0 0x4 0x4 - -[8] 1 6 0x80499cc 0x19cc 0x3c56f .text - 0 0 0x4 0 - -[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini - 0 0 0x4 0 - -[10] 1 2 0x8085f40 0x3df40 0x69c .rodata - 0 0 0x4 0 - -[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 - 0 0 0x4 0 - -[12] 1 3 0x8088330 0x3f330 0x20afc .data - 0 0 0x4 0 - -[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 - 0 0 0x4 0 - -[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got - 0 0 0x4 0x4 - -[15] 6 3 0x80a9874 0x60874 0x80 .dynamic - 4 0 0x4 0x8 - -[16] 8 3 0x80c6800 0x7d800 0 .bss - 0 0 0x4 0 - -[17] 2 0 0 0x7d800 0x9b90 .symtab - 18 371 0x4 0x10 - -[18] 3 0 0 0x87390 0x8526 .strtab - 0 0 0x1 0 - -[19] 3 0 0 0x8f8b6 0x93 .shstrtab - 0 0 0x1 0 - -[20] 1 0 0 0x8f949 0x68b7 .comment - 0 0 0x1 0 - -[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data - 0 0 0x4 0 - - * This is an example of how the file header is changed. "Shoff" is - * the section header offset within the file. Since that table is - * after the new .data section, it is moved. "Shnum" is the number of - * sections, which we increment. - * - * "Phoff" is the file offset to the program header. "Phentsize" and - * "Shentsz" are the program and section header entries sizes respectively. - * These can be larger than the apparent struct sizes. - -raid:/nfs/raid/src/dist-18.56/src> dump -f temacs - -temacs: - - **** ELF HEADER **** -Class Data Type Machine Version -Entry Phoff Shoff Flags Ehsize -Phentsize Phnum Shentsz Shnum Shstrndx - -1 1 2 3 1 -0x80499cc 0x34 0x792f4 0 0x34 -0x20 5 0x28 21 19 - -raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs - -xemacs: - - **** ELF HEADER **** -Class Data Type Machine Version -Entry Phoff Shoff Flags Ehsize -Phentsize Phnum Shentsz Shnum Shstrndx - -1 1 2 3 1 -0x80499cc 0x34 0x96200 0 0x34 -0x20 5 0x28 22 19 - - * These are the program headers. "Offset" is the file offset to the - * segment. "Vaddr" is the memory load address. "Filesz" is the - * segment size as it appears in the file, and "Memsz" is the size in - * memory. Below, the third segment is the code and the fourth is the - * data: the difference between Filesz and Memsz is .bss - -raid:/nfs/raid/src/dist-18.56/src> dump -o temacs - -temacs: - ***** PROGRAM EXECUTION HEADER ***** -Type Offset Vaddr Paddr -Filesz Memsz Flags Align - -6 0x34 0x8048034 0 -0xa0 0xa0 5 0 - -3 0xd4 0 0 -0x13 0 4 0 - -1 0x34 0x8048034 0 -0x3f2f9 0x3f2f9 5 0x1000 - -1 0x3f330 0x8088330 0 -0x215c4 0x25a60 7 0x1000 - -2 0x60874 0x80a9874 0 -0x80 0 7 0 - -raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs - -xemacs: - ***** PROGRAM EXECUTION HEADER ***** -Type Offset Vaddr Paddr -Filesz Memsz Flags Align - -6 0x34 0x8048034 0 -0xa0 0xa0 5 0 - -3 0xd4 0 0 -0x13 0 4 0 - -1 0x34 0x8048034 0 -0x3f2f9 0x3f2f9 5 0x1000 - -1 0x3f330 0x8088330 0 -0x3e4d0 0x3e4d0 7 0x1000 - -2 0x60874 0x80a9874 0 -0x80 0 7 0 - - - */ - -/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. - * - * The above mechanism does not work if the unexeced ELF file is being - * re-layout by other applications (such as `strip'). All the applications - * that re-layout the internal of ELF will layout all sections in ascending - * order of their file offsets. After the re-layout, the data2 section will - * still be the LAST section in the section header vector, but its file offset - * is now being pushed far away down, and causes part of it not to be mapped - * in (ie. not covered by the load segment entry in PHDR vector), therefore - * causes the new binary to fail. - * - * The solution is to modify the unexec algorithm to insert the new data2 - * section header right before the new bss section header, so their file - * offsets will be in the ascending order. Since some of the section's (all - * sections AFTER the bss section) indexes are now changed, we also need to - * modify some fields to make them point to the right sections. This is done - * by macro PATCH_INDEX. All the fields that need to be patched are: - * - * 1. ELF header e_shstrndx field. - * 2. section header sh_link and sh_info field. - * 3. symbol table entry st_shndx field. - * - * The above example now should look like: - - **** SECTION HEADER TABLE **** -[No] Type Flags Addr Offset Size Name - Link Info Adralgn Entsize - -[1] 1 2 0x80480d4 0xd4 0x13 .interp - 0 0 0x1 0 - -[2] 5 2 0x80480e8 0xe8 0x388 .hash - 3 0 0x4 0x4 - -[3] 11 2 0x8048470 0x470 0x7f0 .dynsym - 4 1 0x4 0x10 - -[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr - 0 0 0x1 0 - -[5] 9 2 0x8049010 0x1010 0x338 .rel.plt - 3 7 0x4 0x8 - -[6] 1 6 0x8049348 0x1348 0x3 .init - 0 0 0x4 0 - -[7] 1 6 0x804934c 0x134c 0x680 .plt - 0 0 0x4 0x4 - -[8] 1 6 0x80499cc 0x19cc 0x3c56f .text - 0 0 0x4 0 - -[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini - 0 0 0x4 0 - -[10] 1 2 0x8085f40 0x3df40 0x69c .rodata - 0 0 0x4 0 - -[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 - 0 0 0x4 0 - -[12] 1 3 0x8088330 0x3f330 0x20afc .data - 0 0 0x4 0 - -[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 - 0 0 0x4 0 - -[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got - 0 0 0x4 0x4 - -[15] 6 3 0x80a9874 0x60874 0x80 .dynamic - 4 0 0x4 0x8 - -[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data - 0 0 0x4 0 - -[17] 8 3 0x80c6800 0x7d800 0 .bss - 0 0 0x4 0 - -[18] 2 0 0 0x7d800 0x9b90 .symtab - 19 371 0x4 0x10 - -[19] 3 0 0 0x87390 0x8526 .strtab - 0 0 0x1 0 - -[20] 3 0 0 0x8f8b6 0x93 .shstrtab - 0 0 0x1 0 - -[21] 1 0 0 0x8f949 0x68b7 .comment - 0 0 0x1 0 - - */ - -#include <config.h> -#include <sys/types.h> -#include <stdio.h> -#include <sys/stat.h> -#include <memory.h> -#include <string.h> -#include <errno.h> -#include <unistd.h> -#include <fcntl.h> -#include <elf.h> -#include <syms.h> /* for HDRR declaration */ -#include <sys/mman.h> - -#ifndef emacs -#define fatal(a, b, c) fprintf(stderr, a, b, c), exit(1) -#else -extern void fatal(char *, ...); -#endif - -/* Get the address of a particular section or program header entry, - * accounting for the size of the entries. - */ - -#define OLD_SECTION_H(n) \ - (*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) -#define NEW_SECTION_H(n) \ - (*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) -#define OLD_PROGRAM_H(n) \ - (*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) -#define NEW_PROGRAM_H(n) \ - (*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) - -#define PATCH_INDEX(n) \ - do { \ - if ((n) >= old_bss_index) \ - (n)++; } while (0) -typedef unsigned char byte; - -/* Round X up to a multiple of Y. */ - -int -round_up (x, y) - int x, y; -{ - int rem = x % y; - if (rem == 0) - return x; - return x - rem + y; -} - -/* Return the index of the section named NAME. - SECTION_NAMES, FILE_NAME and FILE_H give information - about the file we are looking in. - - If we don't find the section NAME, that is a fatal error - if NOERROR is 0; we return -1 if NOERROR is nonzero. */ - -static int -find_section (name, section_names, file_name, old_file_h, old_section_h, noerror) - char *name; - char *section_names; - char *file_name; - Elf32_Ehdr *old_file_h; - Elf32_Shdr *old_section_h; - int noerror; -{ - int idx; - - for (idx = 1; idx < old_file_h->e_shnum; idx++) - { -#ifdef DEBUG - fprintf (stderr, "Looking for %s - found %s\n", name, - section_names + OLD_SECTION_H (idx).sh_name); -#endif - if (!strcmp (section_names + OLD_SECTION_H (idx).sh_name, - name)) - break; - } - if (idx == old_file_h->e_shnum) - { - if (noerror) - return -1; - else - fatal ("Can't find .bss in %s.\n", file_name, 0); - } - - return idx; -} - -/* **************************************************************** - * unexec - * - * driving logic. - * - * In ELF, this works by replacing the old .bss section with a new - * .data section, and inserting an empty .bss immediately afterwards. - * - */ -void -unexec (new_name, old_name, data_start, bss_start, entry_address) - char *new_name, *old_name; - unsigned data_start, bss_start, entry_address; -{ - extern unsigned int bss_end; - int new_file, old_file, new_file_size; - - /* Pointers to the base of the image of the two files. */ - caddr_t old_base, new_base; - - /* Pointers to the file, program and section headers for the old and new - files. */ - Elf32_Ehdr *old_file_h, *new_file_h; - Elf32_Phdr *old_program_h, *new_program_h; - Elf32_Shdr *old_section_h, *new_section_h; - - /* Point to the section name table in the old file. */ - char *old_section_names; - - Elf32_Addr old_bss_addr, new_bss_addr; - Elf32_Word old_bss_size, new_data2_size; - Elf32_Off new_data2_offset; - Elf32_Addr new_data2_addr; - Elf32_Addr new_offsets_shift; - - int n, nn, old_bss_index, old_data_index, new_data2_index; - int old_mdebug_index; - struct stat stat_buf; - - /* Open the old file & map it into the address space. */ - - old_file = open (old_name, O_RDONLY); - - if (old_file < 0) - fatal ("Can't open %s for reading: errno %d\n", old_name, errno); - - if (fstat (old_file, &stat_buf) == -1) - fatal ("Can't fstat(%s): errno %d\n", old_name, errno); - - old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0); - - if (old_base == (caddr_t) -1) - fatal ("Can't mmap(%s): errno %d\n", old_name, errno); - -#ifdef DEBUG - fprintf (stderr, "mmap(%s, %x) -> %x\n", old_name, stat_buf.st_size, - old_base); -#endif - - /* Get pointers to headers & section names. */ - - old_file_h = (Elf32_Ehdr *) old_base; - old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff); - old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff); - old_section_names - = (char *) old_base + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; - - /* Find the mdebug section, if any. */ - - old_mdebug_index = find_section (".mdebug", old_section_names, - old_name, old_file_h, old_section_h, 1); - - /* Find the old .bss section. */ - - old_bss_index = find_section (".bss", old_section_names, - old_name, old_file_h, old_section_h, 0); - - /* Find the old .data section. Figure out parameters of - the new data2 and bss sections. */ - - old_data_index = find_section (".data", old_section_names, - old_name, old_file_h, old_section_h, 0); - - old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; - old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; -#if defined(emacs) || !defined(DEBUG) - bss_end = (unsigned int) sbrk (0); - new_bss_addr = (Elf32_Addr) bss_end; -#else - new_bss_addr = old_bss_addr + old_bss_size + 0x1234; -#endif - new_data2_addr = old_bss_addr; - new_data2_size = new_bss_addr - old_bss_addr; - new_data2_offset = OLD_SECTION_H (old_data_index).sh_offset + - (new_data2_addr - OLD_SECTION_H (old_data_index).sh_addr); - new_offsets_shift = new_bss_addr - - ((old_bss_addr & ~0xfff) + ((old_bss_addr & 0xfff) ? 0x1000 : 0)); - -#ifdef DEBUG - fprintf (stderr, "old_bss_index %d\n", old_bss_index); - fprintf (stderr, "old_bss_addr %x\n", old_bss_addr); - fprintf (stderr, "old_bss_size %x\n", old_bss_size); - fprintf (stderr, "new_bss_addr %x\n", new_bss_addr); - fprintf (stderr, "new_data2_addr %x\n", new_data2_addr); - fprintf (stderr, "new_data2_size %x\n", new_data2_size); - fprintf (stderr, "new_data2_offset %x\n", new_data2_offset); - fprintf (stderr, "new_offsets_shift %x\n", new_offsets_shift); -#endif - - if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) - fatal (".bss shrank when undumping???\n", 0, 0); - - /* Set the output file to the right size and mmap it. Set - pointers to various interesting objects. stat_buf still has - old_file data. */ - - new_file = open (new_name, O_RDWR | O_CREAT, 0666); - if (new_file < 0) - fatal ("Can't creat (%s): errno %d\n", new_name, errno); - - new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_offsets_shift; - - if (ftruncate (new_file, new_file_size)) - fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); - - new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED, - new_file, 0); - - if (new_base == (caddr_t) -1) - fatal ("Can't mmap (%s): errno %d\n", new_name, errno); - - new_file_h = (Elf32_Ehdr *) new_base; - new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff); - new_section_h - = (Elf32_Shdr *) ((byte *) new_base + old_file_h->e_shoff - + new_offsets_shift); - - /* Make our new file, program and section headers as copies of the - originals. */ - - memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); - memcpy (new_program_h, old_program_h, - old_file_h->e_phnum * old_file_h->e_phentsize); - - /* Modify the e_shstrndx if necessary. */ - PATCH_INDEX (new_file_h->e_shstrndx); - - /* Fix up file header. We'll add one section. Section header is - further away now. */ - - new_file_h->e_shoff += new_offsets_shift; - new_file_h->e_shnum += 1; - -#ifdef DEBUG - fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff); - fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum); - fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff); - fprintf (stderr, "New section count %d\n", new_file_h->e_shnum); -#endif - - /* Fix up a new program header. Extend the writable data segment so - that the bss area is covered too. Find that segment by looking - for a segment that ends just before the .bss area. Make sure - that no segments are above the new .data2. Put a loop at the end - to adjust the offset and address of any segment that is above - data2, just in case we decide to allow this later. */ - - for (n = new_file_h->e_phnum - 1; n >= 0; n--) - { - /* Compute maximum of all requirements for alignment of section. */ - int alignment = (NEW_PROGRAM_H (n)).p_align; - if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) - alignment = OLD_SECTION_H (old_bss_index).sh_addralign; - - /* Supposedly this condition is okay for the SGI. */ -#if 0 - if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr) - fatal ("Program segment above .bss in %s\n", old_name, 0); -#endif - - if (NEW_PROGRAM_H (n).p_type == PT_LOAD - && (round_up ((NEW_PROGRAM_H (n)).p_vaddr - + (NEW_PROGRAM_H (n)).p_filesz, - alignment) - == round_up (old_bss_addr, alignment))) - break; - } - if (n < 0) - fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0); - - NEW_PROGRAM_H (n).p_filesz += new_offsets_shift; - NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; - -#if 1 /* Maybe allow section after data2 - does this ever happen? */ - for (n = new_file_h->e_phnum - 1; n >= 0; n--) - { - if (NEW_PROGRAM_H (n).p_vaddr - && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) - NEW_PROGRAM_H (n).p_vaddr += new_offsets_shift - old_bss_size; - - if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) - NEW_PROGRAM_H (n).p_offset += new_offsets_shift; - } -#endif - - /* Fix up section headers based on new .data2 section. Any section - whose offset or virtual address is after the new .data2 section - gets its value adjusted. .bss size becomes zero and new address - is set. data2 section header gets added by copying the existing - .data header and modifying the offset, address and size. */ - for (old_data_index = 1; old_data_index < old_file_h->e_shnum; - old_data_index++) - if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, - ".data")) - break; - if (old_data_index == old_file_h->e_shnum) - fatal ("Can't find .data in %s.\n", old_name, 0); - - /* Walk through all section headers, insert the new data2 section right - before the new bss section. */ - for (n = 1, nn = 1; n < old_file_h->e_shnum; n++, nn++) - { - caddr_t src; - - /* If it is bss section, insert the new data2 section before it. */ - if (n == old_bss_index) - { - /* Steal the data section header for this data2 section. */ - memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), - new_file_h->e_shentsize); - - NEW_SECTION_H (nn).sh_addr = new_data2_addr; - NEW_SECTION_H (nn).sh_offset = new_data2_offset; - NEW_SECTION_H (nn).sh_size = new_data2_size; - /* Use the bss section's alignment. This will assure that the - new data2 section always be placed in the same spot as the old - bss section by any other application. */ - NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; - - /* Now copy over what we have in the memory now. */ - memcpy (NEW_SECTION_H (nn).sh_offset + new_base, - (caddr_t) OLD_SECTION_H (n).sh_addr, - new_data2_size); - nn++; - memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), - old_file_h->e_shentsize); - - /* The new bss section's size is zero, and its file offset and virtual - address should be off by NEW_OFFSETS_SHIFT. */ - NEW_SECTION_H (nn).sh_offset += new_offsets_shift; - NEW_SECTION_H (nn).sh_addr = new_bss_addr; - /* Let the new bss section address alignment be the same as the - section address alignment followed the old bss section, so - this section will be placed in exactly the same place. */ - NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; - NEW_SECTION_H (nn).sh_size = 0; - } - else - { - memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), - old_file_h->e_shentsize); - - /* Any section that was original placed AFTER the bss - section must now be adjusted by NEW_OFFSETS_SHIFT. */ - - if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) - NEW_SECTION_H (nn).sh_offset += new_offsets_shift; - } - - /* If any section hdr refers to the section after the new .data - section, make it refer to next one because we have inserted - a new section in between. */ - - PATCH_INDEX (NEW_SECTION_H (nn).sh_link); - /* For symbol tables, info is a symbol table index, - so don't change it. */ - if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB - && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) - PATCH_INDEX (NEW_SECTION_H (nn).sh_info); - - /* Now, start to copy the content of sections. */ - if (NEW_SECTION_H (nn).sh_type == SHT_NULL - || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) - continue; - - /* Write out the sections. .data and .data1 (and data2, called - ".data" in the strings table) get copied from the current process - instead of the old file. */ - if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data") - || !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data1") -#ifdef IRIX6_5 - /* Under IRIX 6.5 gcc places objects with adresses relative to - shared symbols in the section .rodata, which are adjusted at - startup time. Unfortunately they aren't adjusted after unexec, - so with this configuration we must get .rodata also from memory. - Do any other configurations need this, too? - <Wolfgang.Glas@hfm.tu-graz.ac.at> 1999-06-08. */ - || !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".rodata") -#endif - || !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".got")) - src = (caddr_t) OLD_SECTION_H (n).sh_addr; - else - src = old_base + OLD_SECTION_H (n).sh_offset; - - memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, - NEW_SECTION_H (nn).sh_size); - - /* Adjust the HDRR offsets in .mdebug and copy the - line data if it's in its usual 'hole' in the object. - Makes the new file debuggable with dbx. - patches up two problems: the absolute file offsets - in the HDRR record of .mdebug (see /usr/include/syms.h), and - the ld bug that gets the line table in a hole in the - elf file rather than in the .mdebug section proper. - David Anderson. davea@sgi.com Jan 16,1994. */ - if (n == old_mdebug_index) - { -#define MDEBUGADJUST(__ct,__fileaddr) \ - if (n_phdrr->__ct > 0) \ - { \ - n_phdrr->__fileaddr += movement; \ - } - - HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset); - HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset); - unsigned movement = new_offsets_shift; - - MDEBUGADJUST (idnMax, cbDnOffset); - MDEBUGADJUST (ipdMax, cbPdOffset); - MDEBUGADJUST (isymMax, cbSymOffset); - MDEBUGADJUST (ioptMax, cbOptOffset); - MDEBUGADJUST (iauxMax, cbAuxOffset); - MDEBUGADJUST (issMax, cbSsOffset); - MDEBUGADJUST (issExtMax, cbSsExtOffset); - MDEBUGADJUST (ifdMax, cbFdOffset); - MDEBUGADJUST (crfd, cbRfdOffset); - MDEBUGADJUST (iextMax, cbExtOffset); - /* The Line Section, being possible off in a hole of the object, - requires special handling. */ - if (n_phdrr->cbLine > 0) - { - if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset - + OLD_SECTION_H (n).sh_size)) - { - /* line data is in a hole in elf. do special copy and adjust - for this ld mistake. - */ - n_phdrr->cbLineOffset += movement; - - memcpy (n_phdrr->cbLineOffset + new_base, - o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine); - } - else - { - /* somehow line data is in .mdebug as it is supposed to be. */ - MDEBUGADJUST (cbLine, cbLineOffset); - } - } - } - - /* If it is the symbol table, its st_shndx field needs to be patched. */ - if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB - || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) - { - Elf32_Shdr *spt = &NEW_SECTION_H (nn); - unsigned int num = spt->sh_size / spt->sh_entsize; - Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset - + new_base); - for (; num--; sym++) - { - /* don't patch special section indices. */ - if (sym->st_shndx == SHN_UNDEF - || sym->st_shndx >= SHN_LORESERVE) - continue; - - PATCH_INDEX (sym->st_shndx); - } - } - } - - /* Close the files and make the new file executable. */ - - if (close (old_file)) - fatal ("Can't close (%s): errno %d\n", old_name, errno); - - if (close (new_file)) - fatal ("Can't close (%s): errno %d\n", new_name, errno); - - if (stat (new_name, &stat_buf) == -1) - fatal ("Can't stat (%s): errno %d\n", new_name, errno); - - n = umask (777); - umask (n); - stat_buf.st_mode |= 0111 & ~n; - if (chmod (new_name, stat_buf.st_mode) == -1) - fatal ("Can't chmod (%s): errno %d\n", new_name, errno); -}
--- a/src/=x11term.h Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -#include <X11/Xlib.h> -#include <X11/Xatom.h> -#include <X11/keysym.h> -#include <X11/cursorfont.h> -#include <X11/Xutil.h> -#include <X11/X10.h> - -#define XMOUSEBUFSIZE 64 - -#ifndef sigmask -#define sigmask(no) (1L << ((no) - 1)) -#endif - -#define BLOCK_INPUT_DECLARE() int BLOCK_INPUT_mask -#ifdef SIGIO -#define BLOCK_INPUT() EMACS_SIGBLOCKX (SIGIO, BLOCK_INPUT_mask) -#define UNBLOCK_INPUT() \ - do { int _dummy; EMACS_SIGSETMASK (BLOCK_INPUT_mask, _dummy); } while (0) -#else /* not SIGIO */ -#define BLOCK_INPUT() -#define UNBLOCK_INPUT() -#endif /* SIGIO */ - -#define CLASS "Emacs" /* class id for GNU Emacs, used in .Xdefaults, etc. */
--- a/src/=xscrollbar.h Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,123 +0,0 @@ -/* Bitmaps and things for scrollbars. - Copyright (C) 1989 Free Software Foundation. - -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 1, 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. */ - - -static void install_vertical_scrollbar (); -static void install_horizontal_scrollbar (); -static void x_set_horizontal_scrollbar (); -static void x_set_vertical_scrollbar (); - -/* Prefix-characters for scroll bar commands in Vglobal_mouse_map. - Choice of prefix depends on which region of the scroll bar. */ - -enum scroll_bar_prefix - { VSCROLL_BAR_PREFIX = 050, VSCROLL_SLIDER_PREFIX /* unused */, - VSCROLL_THUMBUP_PREFIX, VSCROLL_THUMBDOWN_PREFIX, - HSCROLL_BAR_PREFIX, HSCROLL_SLIDER_PREFIX /* unused */, - HSCROLL_THUMBLEFT_PREFIX, HSCROLL_THUMBRIGHT_PREFIX }; - -#define CROSS_WIDTH 16 -#define CROSS_HEIGHT 16 - -#define CROSS_MASK_WIDTH 16 -#define CROSS_MASK_HEIGHT 16 - -/* Vertical and Horizontal scroll bar widths. */ -#define VSCROLL_WIDTH 18 -#define HSCROLL_HEIGHT 18 - -#ifdef HAVE_X11 - -/* Arrow cursors for scroll bars. */ - -Cursor up_arrow_cursor, down_arrow_cursor, v_double_arrow_cursor; -Cursor left_arrow_cursor, right_arrow_cursor, h_double_arrow_cursor; - -static char cross_bits[] = - { - 0x00, 0x00, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, - 0x80, 0x01, 0xfe, 0x7f, 0xfe, 0x7f, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, - 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x00, 0x00 - }; - -static char gray_bits[] = - { - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa, - 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa - }; - -static char up_arrow_bits[] = - { - 0x00, 0x00, 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f, 0xf8, 0x1f, - 0xfc, 0x3f, 0xfe, 0x7f, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, - 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0xff, 0xff - }; - -static char down_arrow_bits[] = - { - 0xff, 0xff, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, - 0x80, 0x01, 0x80, 0x01, 0xfe, 0x7f, 0xfc, 0x3f, 0xf8, 0x1f, 0xf0, 0x0f, - 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01, 0x00, 0x00 - }; - -static char left_arrow_bits[] = - { - 0x00, 0x80, 0x80, 0x80, 0xc0, 0x80, 0xe0, 0x80, 0xf0, 0x80, 0xf8, 0x80, - 0xfc, 0x80, 0xfe, 0xff, 0xfe, 0xff, 0xfc, 0x80, 0xf8, 0x80, 0xf0, 0x80, - 0xe0, 0x80, 0xc0, 0x80, 0x80, 0x80, 0x00, 0x80 - }; - -static char right_arrow_bits[] = - { - 0x01, 0x00, 0x01, 0x01, 0x01, 0x03, 0x01, 0x07, 0x01, 0x0f, 0x01, 0x1f, - 0x01, 0x3f, 0xff, 0x7f, 0xff, 0x7f, 0x01, 0x3f, 0x01, 0x1f, 0x01, 0x0f, - 0x01, 0x07, 0x01, 0x03, 0x01, 0x01, 0x01, 0x00 - }; - -static char cross_mask_bits[] = - { - 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03, - 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xc0, 0x03, 0xc0, 0x03, - 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03 - }; -#else /* not HAVE_X11 */ -static short cross_bits[] = - { - 0x0000, 0x0180, 0x0180, 0x0180, - 0x0180, 0x0180, 0x0180, 0x7ffe, - 0x7ffe, 0x0180, 0x0180, 0x0180, - 0x0180, 0x0180, 0x0180, 0x0000, - }; - -static short gray_bits[] = { - 0xaaaa, 0x5555, 0xaaaa, 0x5555, - 0xaaaa, 0x5555, 0xaaaa, 0x5555, - 0xaaaa, 0x5555, 0xaaaa, 0x5555, - 0xaaaa, 0x5555, 0xaaaa, 0x5555}; - -static short cross_mask_bits[] = - { - 0x03c0, 0x03c0, 0x03c0, 0x03c0, - 0x03c0, 0x03c0, 0xffff, 0xffff, - 0xffff, 0xffff, 0x03c0, 0x03c0, - 0x03c0, 0x03c0, 0x03c0, 0x03c0, - }; -#endif /* X10 */
--- a/src/=xselect.c.old Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,950 +0,0 @@ -/* X Selection processing for emacs - Copyright (C) 1990, 1992, 1993 Free Software Foundation. - -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. */ - -#include "config.h" -#include "lisp.h" -#include "xterm.h" -#include "buffer.h" -#include "frame.h" - -#ifdef HAVE_X11 - -/* Macros for X Selections */ -#define MAX_SELECTION(dpy) (((dpy)->max_request_size << 2) - 100) -#define SELECTION_LENGTH(len,format) ((len) * ((format) >> 2)) - -/* The timestamp of the last input event we received from the X server. */ -unsigned long last_event_timestamp; - -/* t if a mouse button is depressed. */ -extern Lisp_Object Vmouse_grabbed; - -/* When emacs became the PRIMARY selection owner. */ -Time x_begin_selection_own; - -/* When emacs became the SECONDARY selection owner. */ -Time x_begin_secondary_selection_own; - -/* When emacs became the CLIPBOARD selection owner. */ -Time x_begin_clipboard_own; - -/* The value of the current CLIPBOARD selection. */ -Lisp_Object Vx_clipboard_value; - -/* The value of the current PRIMARY selection. */ -Lisp_Object Vx_selection_value; - -/* The value of the current SECONDARY selection. */ -Lisp_Object Vx_secondary_selection_value; - -/* Types of selections we may make. */ -Lisp_Object Qprimary, Qsecondary, Qclipboard; - -/* Emacs' selection property identifiers. */ -Atom Xatom_emacs_selection; -Atom Xatom_emacs_secondary_selection; - -/* Clipboard selection atom. */ -Atom Xatom_clipboard_selection; - -/* Clipboard atom. */ -Atom Xatom_clipboard; - -/* Atom for indicating incremental selection transfer. */ -Atom Xatom_incremental; - -/* Atom for indicating multiple selection request list */ -Atom Xatom_multiple; - -/* Atom for what targets emacs handles. */ -Atom Xatom_targets; - -/* Atom for indicating timstamp selection request */ -Atom Xatom_timestamp; - -/* Atom requesting we delete our selection. */ -Atom Xatom_delete; - -/* Selection magic. */ -Atom Xatom_insert_selection; - -/* Type of property for INSERT_SELECTION. */ -Atom Xatom_pair; - -/* More selection magic. */ -Atom Xatom_insert_property; - -/* Atom for indicating property type TEXT */ -Atom Xatom_text; - -/* Kinds of protocol things we may receive. */ -Atom Xatom_wm_take_focus; -Atom Xatom_wm_save_yourself; -Atom Xatom_wm_delete_window; - -/* Communication with window managers. */ -Atom Xatom_wm_protocols; - -/* These are to handle incremental selection transfer. */ -Window incr_requestor; -Atom incr_property; -int incr_nbytes; -unsigned char *incr_value; -unsigned char *incr_ptr; - -/* Declarations for handling cut buffers. - - Whenever we set a cut buffer or read a cut buffer's value, we cache - it in cut_buffer_value. We look for PropertyNotify events about - the CUT_BUFFER properties, and invalidate our cache accordingly. - We ignore PropertyNotify events that we suspect were caused by our - own changes to the cut buffers, so we can keep the cache valid - longer. - - IS ALL THIS HAIR WORTH IT? Well, these functions get called every - time an element goes into or is retrieved from the kill ring, and - those ought to be quick. It's not fun in time or space to wait for - 50k cut buffers to fly back and forth across the net. */ - -/* The number of CUT_BUFFER properties defined under X. */ -#define NUM_CUT_BUFFERS (8) - -/* cut_buffer_atom[n] is the atom naming the nth cut buffer. */ -static Atom cut_buffer_atom[NUM_CUT_BUFFERS] = { - XA_CUT_BUFFER0, XA_CUT_BUFFER1, XA_CUT_BUFFER2, XA_CUT_BUFFER3, - XA_CUT_BUFFER4, XA_CUT_BUFFER5, XA_CUT_BUFFER6, XA_CUT_BUFFER7 -}; - -/* cut_buffer_value is an eight-element vector; - (aref cut_buffer_value n) is the cached value of cut buffer n, or - Qnil if cut buffer n is unset. */ -static Lisp_Object cut_buffer_value; - -/* Bit N of cut_buffer_cached is true if (aref cut_buffer_value n) is - known to be valid. This is cleared by PropertyNotify events - handled by x_invalidate_cut_buffer_cache. It would be wonderful if - that routine could just set the appropriate element of - cut_buffer_value to some special value meaning "uncached", but that - would lose if a GC happened to be in progress. - - Bit N of cut_buffer_just_set is true if cut buffer N has been set since - the last PropertyNotify event; since we get an event even when we set - the property ourselves, we should ignore one event after setting - a cut buffer, so we don't have to throw away our cache. */ -#ifdef __STDC__ -volatile -#endif -static cut_buffer_cached, cut_buffer_just_set; - - -/* Acquiring ownership of a selection. */ - - -/* Request selection ownership if we do not already have it. */ - -static int -own_selection (selection_type, time) - Atom selection_type; - Time time; -{ - Window owner_window, selecting_window; - - if ((selection_type == XA_PRIMARY - && !NILP (Vx_selection_value)) - || (selection_type == XA_SECONDARY - && !NILP (Vx_secondary_selection_value)) - || (selection_type == Xatom_clipboard - && !NILP (Vx_clipboard_value))) - return 1; - - selecting_window = FRAME_X_WINDOW (selected_frame); - XSetSelectionOwner (x_current_display, selection_type, - selecting_window, time); - owner_window = XGetSelectionOwner (x_current_display, selection_type); - - if (owner_window != selecting_window) - return 0; - - return 1; -} - -/* Become the selection owner and make our data the selection value. - If we are already the owner, merely change data and timestamp values. - This avoids generating SelectionClear events for ourselves. */ - -DEFUN ("x-set-selection", Fx_set_selection, Sx_set_selection, - 2, 2, "", - "Set the value of SELECTION to STRING.\n\ -SELECTION may be `primary', `secondary', or `clipboard'.\n\ -\n\ -Selections are a mechanism for cutting and pasting information between\n\ -X Windows clients. Emacs's kill ring commands set the `primary'\n\ -selection to the top string of the kill ring, making it available to\n\ -other clients, like xterm. Those commands also use the `primary'\n\ -selection to retrieve information from other clients.\n\ -\n\ -According to the Inter-Client Communications Conventions Manual:\n\ -\n\ -The `primary' selection \"... is used for all commands that take only a\n\ - single argument and is the principal means of communication between\n\ - clients that use the selection mechanism.\" In Emacs, this means\n\ - that the kill ring commands set the primary selection to the text\n\ - put in the kill ring.\n\ -\n\ -The `secondary' selection \"... is used as the second argument to\n\ - commands taking two arguments (for example, `exchange primary and\n\ - secondary selections'), and as a means of obtaining data when there\n\ - is a primary selection and the user does not want to disturb it.\"\n\ - I am not sure how Emacs should use the secondary selection; if you\n\ - come up with ideas, this function will at least let you get at it.\n\ -\n\ -The `clipboard' selection \"... is used to hold data that is being\n\ - transferred between clients, that is, data that usually is being\n\ - cut or copied, and then pasted.\" It seems that the `clipboard'\n\ - selection is for the most part equivalent to the `primary'\n\ - selection, so Emacs sets them both.\n\ -\n\ -Also see `x-selection', and the `interprogram-cut-function' variable.") - (selection, string) - register Lisp_Object selection, string; -{ - Atom selection_type; - Lisp_Object val; - Time event_time = last_event_timestamp; - CHECK_STRING (string, 0); - - val = Qnil; - - if (NILP (selection) || EQ (selection, Qprimary)) - { - BLOCK_INPUT; - if (own_selection (XA_PRIMARY, event_time)) - { - x_begin_selection_own = event_time; - val = Vx_selection_value = string; - } - UNBLOCK_INPUT; - } - else if (EQ (selection, Qsecondary)) - { - BLOCK_INPUT; - if (own_selection (XA_SECONDARY, event_time)) - { - x_begin_secondary_selection_own = event_time; - val = Vx_secondary_selection_value = string; - } - UNBLOCK_INPUT; - } - else if (EQ (selection, Qclipboard)) - { - BLOCK_INPUT; - if (own_selection (Xatom_clipboard, event_time)) - { - x_begin_clipboard_own = event_time; - val = Vx_clipboard_value = string; - } - UNBLOCK_INPUT; - } - else - error ("Invalid X selection type"); - - return val; -} - -/* Clear our selection ownership data, as some other client has - become the owner. */ - -void -x_disown_selection (old_owner, selection, changed_owner_time) - Window *old_owner; - Atom selection; - Time changed_owner_time; -{ - struct frame *s = x_window_to_frame (old_owner); - - if (s) /* We are the owner */ - { - if (selection == XA_PRIMARY) - { - x_begin_selection_own = 0; - Vx_selection_value = Qnil; - } - else if (selection == XA_SECONDARY) - { - x_begin_secondary_selection_own = 0; - Vx_secondary_selection_value = Qnil; - } - else if (selection == Xatom_clipboard) - { - x_begin_clipboard_own = 0; - Vx_clipboard_value = Qnil; - } - else - abort (); - } - else - abort (); /* Inconsistent state. */ -} - - -/* Answering selection requests. */ - -int x_selection_alloc_error; -int x_converting_selection; - -/* Reply to some client's request for our selection data. - Data is placed in a property supplied by the requesting window. - - If the data exceeds the maximum amount the server can send, - then prepare to send it incrementally, and reply to the client with - the total size of the data. - - But first, check for all the other crufty stuff we could get. */ - -void -x_answer_selection_request (event) - XSelectionRequestEvent event; -{ - Time emacs_own_time; - Lisp_Object selection_value; - XSelectionEvent evt; - int format = 8; /* We have only byte sized (text) data. */ - - evt.type = SelectionNotify; /* Construct reply event */ - evt.display = event.display; - evt.requestor = event.requestor; - evt.selection = event.selection; - evt.time = event.time; - evt.target = event.target; - - if (event.selection == XA_PRIMARY) - { - emacs_own_time = x_begin_selection_own; - selection_value = Vx_selection_value; - } - else if (event.selection == XA_SECONDARY) - { - emacs_own_time = x_begin_secondary_selection_own; - selection_value = Vx_secondary_selection_value; - } - else if (event.selection == Xatom_clipboard) - { - emacs_own_time = x_begin_clipboard_own; - selection_value = Vx_clipboard_value; - } - else - abort (); - - if (event.time != CurrentTime - && event.time < emacs_own_time) - evt.property = None; - else - { - if (event.property == None) /* obsolete client */ - evt.property = event.target; - else - evt.property = event.property; - } - - if (event.target == Xatom_targets) /* Send List of target atoms */ - { - } - else if (event.target == Xatom_multiple) /* Recvd list: <target, prop> */ - { - Atom type; - int return_format; - unsigned long items, bytes_left; - unsigned char *data; - int result, i; - - if (event.property == 0 /* 0 == NILP */ - || event.property == None) - return; - - result = XGetWindowProperty (event.display, event.requestor, - event.property, 0L, 10000000L, - True, Xatom_pair, &type, &return_format, - &items, &bytes_left, &data); - - if (result == Success && type == Xatom_pair) - for (i = items; i > 0; i--) - { - /* Convert each element of the list. */ - } - - (void) XSendEvent (x_current_display, evt.requestor, False, - 0L, (XEvent *) &evt); - return; - } - else if (event.target == Xatom_timestamp) /* Send ownership timestamp */ - { - if (! emacs_own_time) - abort (); - - format = 32; - XChangeProperty (evt.display, evt.requestor, evt.property, - evt.target, format, PropModeReplace, - (unsigned char *) &emacs_own_time, 1); - return; - } - else if (event.target == Xatom_delete) /* Delete our selection. */ - { - if (EQ (Qnil, selection_value)) - abort (); - - x_disown_selection (event.owner, event.selection, event.time); - - /* Now return property of type NILP, length 0. */ - XChangeProperty (event.display, event.requestor, event.property, - 0, format, PropModeReplace, (unsigned char *) 0, 0); - return; - } - else if (event.target == Xatom_insert_selection) - { - Atom type; - int return_format; - unsigned long items, bytes_left; - unsigned char *data; - int result = XGetWindowProperty (event.display, event.requestor, - event.property, 0L, 10000000L, - True, Xatom_pair, &type, &return_format, - &items, &bytes_left, &data); - if (result == Success && type == Xatom_pair) - { - /* Convert the first atom to (a selection) to the target - indicated by the second atom. */ - } - } - else if (event.target == Xatom_insert_property) - { - Atom type; - int return_format; - unsigned long items, bytes_left; - unsigned char *data; - int result = XGetWindowProperty (event.display, event.requestor, - event.property, 0L, 10000000L, - True, XA_STRING, &type, &return_format, - &items, &bytes_left, &data); - - if (result == Success && type == XA_STRING && return_format == 8) - { - if (event.selection == Xatom_emacs_selection) - Vx_selection_value = make_string (data); - else if (event.selection == Xatom_emacs_secondary_selection) - Vx_secondary_selection_value = make_string (data); - else if (event.selection == Xatom_clipboard_selection) - Vx_clipboard_value = make_string (data); - else - abort (); - } - - return; - } - else if ((event.target == Xatom_text - || event.target == XA_STRING)) - { - int size = XSTRING (selection_value)->size; - unsigned char *data = XSTRING (selection_value)->data; - - if (EQ (Qnil, selection_value)) - abort (); - - /* Place data on requestor window's property. */ - if (SELECTION_LENGTH (size, format) - <= MAX_SELECTION (x_current_display)) - { - x_converting_selection = 1; - XChangeProperty (evt.display, evt.requestor, evt.property, - evt.target, format, PropModeReplace, - data, size); - if (x_selection_alloc_error) - { - x_selection_alloc_error = 0; - abort (); - } - x_converting_selection = 0; - } - else /* Send incrementally */ - { - evt.target = Xatom_incremental; - incr_requestor = evt.requestor; - incr_property = evt.property; - x_converting_selection = 1; - - /* Need to handle Alloc errors on these requests. */ - XChangeProperty (evt.display, incr_requestor, incr_property, - Xatom_incremental, 32, - PropModeReplace, - (unsigned char *) &size, 1); - if (x_selection_alloc_error) - { - x_selection_alloc_error = 0; - x_converting_selection = 0; - abort (); - /* Now abort the send. */ - } - - incr_nbytes = size; - incr_value = data; - incr_ptr = data; - - /* Ask for notification when requestor deletes property. */ - XSelectInput (x_current_display, incr_requestor, PropertyChangeMask); - - /* If we're sending incrementally, perhaps block here - until all sent? */ - } - } - else - evt.property = None; - - /* Don't do this if there was an Alloc error: abort the transfer - by sending None. */ - (void) XSendEvent (x_current_display, evt.requestor, False, - 0L, (XEvent *) &evt); -} - -/* Send an increment of selection data in response to a PropertyNotify event. - The increment is placed in a property on the requestor's window. - When the requestor has processed the increment, it deletes the property, - which sends us another PropertyNotify event. - - When there is no more data to send, we send a zero-length increment. */ - -void -x_send_incremental (event) - XPropertyEvent event; -{ - if (incr_requestor - && incr_requestor == event.window - && incr_property == event.atom - && event.state == PropertyDelete) - { - int format = 8; - int length = MAX_SELECTION (x_current_display); - int bytes_left = (incr_nbytes - (incr_ptr - incr_value)); - - if (length > bytes_left) /* Also sends 0 len when finished. */ - length = bytes_left; - XChangeProperty (x_current_display, incr_requestor, - incr_property, XA_STRING, format, - PropModeAppend, incr_ptr, length); - if (x_selection_alloc_error) - { - x_selection_alloc_error = 0; - x_converting_selection = 0; - /* Abandon the transmission. */ - abort (); - } - if (length > 0) - incr_ptr += length; - else - { /* Everything's sent */ - XSelectInput (x_current_display, incr_requestor, 0L); - incr_requestor = (Window) 0; - incr_property = (Atom) 0; - incr_nbytes = 0; - incr_value = (unsigned char *) 0; - incr_ptr = (unsigned char *) 0; - x_converting_selection = 0; - } - } -} - - -/* Requesting the value of a selection. */ - -static Lisp_Object x_selection_arrival (); - -/* Predicate function used to match a requested event. */ - -Bool -XCheckSelectionEvent (dpy, event, window) - Display *dpy; - XEvent *event; - char *window; -{ - if (event->type == SelectionNotify) - if (event->xselection.requestor == (Window) window) - return True; - - return False; -} - -/* Request a selection value from its owner. This will block until - all the data is arrived. */ - -static Lisp_Object -get_selection_value (type) - Atom type; -{ - XEvent event; - Lisp_Object val; - Time requestor_time; /* Timestamp of selection request. */ - Window requestor_window; - - BLOCK_INPUT; - requestor_time = last_event_timestamp; - requestor_window = FRAME_X_WINDOW (selected_frame); - XConvertSelection (x_current_display, type, XA_STRING, - Xatom_emacs_selection, requestor_window, requestor_time); - XIfEvent (x_current_display, - &event, - XCheckSelectionEvent, - (char *) requestor_window); - val = x_selection_arrival (&event, requestor_window, requestor_time); - UNBLOCK_INPUT; - - return val; -} - -/* Request a selection value from the owner. If we are the owner, - simply return our selection value. If we are not the owner, this - will block until all of the data has arrived. */ - -DEFUN ("x-selection", Fx_selection, Sx_selection, - 1, 1, "", - "Return the value of SELECTION.\n\ -SELECTION is one of `primary', `secondary', or `clipboard'.\n\ -\n\ -Selections are a mechanism for cutting and pasting information between\n\ -X Windows clients. When the user selects text in an X application,\n\ -the application should set the primary selection to that text; Emacs's\n\ -kill ring commands will then check the value of the `primary'\n\ -selection, and return it as the most recent kill.\n\ -The documentation for `x-set-selection' gives more information on how\n\ -the different selection types are intended to be used.\n\ -Also see the `interprogram-paste-function' variable.") - (selection) - register Lisp_Object selection; -{ - Atom selection_type; - - if (NILP (selection) || EQ (selection, Qprimary)) - { - if (!NILP (Vx_selection_value)) - return Vx_selection_value; - - return get_selection_value (XA_PRIMARY); - } - else if (EQ (selection, Qsecondary)) - { - if (!NILP (Vx_secondary_selection_value)) - return Vx_secondary_selection_value; - - return get_selection_value (XA_SECONDARY); - } - else if (EQ (selection, Qclipboard)) - { - if (!NILP (Vx_clipboard_value)) - return Vx_clipboard_value; - - return get_selection_value (Xatom_clipboard); - } - else - error ("Invalid X selection type"); -} - -static Lisp_Object -x_selection_arrival (event, requestor_window, requestor_time) - register XSelectionEvent *event; - Window requestor_window; - Time requestor_time; -{ - int result; - Atom type, selection; - int format; - unsigned long items; - unsigned long bytes_left; - unsigned char *data = 0; - int offset = 0; - - if (event->selection == XA_PRIMARY) - selection = Xatom_emacs_selection; - else if (event->selection == XA_SECONDARY) - selection = Xatom_emacs_secondary_selection; - else if (event->selection == Xatom_clipboard) - selection = Xatom_clipboard_selection; - else - abort (); - - if (event->requestor == requestor_window - && event->time == requestor_time - && event->property != None) - if (event->target != Xatom_incremental) - { - unsigned char *return_string = - (unsigned char *) alloca (MAX_SELECTION (x_current_display)); - - do - { - result = XGetWindowProperty (x_current_display, requestor_window, - event->property, 0L, - 10000000L, True, XA_STRING, - &type, &format, &items, - &bytes_left, &data); - if (result == Success && type == XA_STRING && format == 8 - && offset < MAX_SELECTION (x_current_display)) - { - bcopy (data, return_string + offset, items); - offset += items; - } - XFree ((char *) data); - } - while (bytes_left); - - return make_string (return_string, offset); - } - else /* Prepare incremental transfer. */ - { - unsigned char *increment_value; - unsigned char *increment_ptr; - int total_size; - int *increment_nbytes = 0; - - result = XGetWindowProperty (x_current_display, requestor_window, - selection, 0L, 10000000L, False, - event->property, &type, &format, - &items, &bytes_left, - (unsigned char **) &increment_nbytes); - if (result == Success) - { - XPropertyEvent property_event; - - total_size = *increment_nbytes; - increment_value = (unsigned char *) alloca (total_size); - increment_ptr = increment_value; - - XDeleteProperty (x_current_display, event->requestor, - event->property); - XFlush (x_current_display); - XFree ((char *) increment_nbytes); - - do - { /* NOTE: this blocks. */ - XWindowEvent (x_current_display, requestor_window, - PropertyChangeMask, - (XEvent *) &property_event); - - if (property_event.atom == selection - && property_event.state == PropertyNewValue) - do - { - result = XGetWindowProperty (x_current_display, - requestor_window, - selection, 0L, - 10000000L, True, - AnyPropertyType, - &type, &format, - &items, &bytes_left, - &data); - if (result == Success && type == XA_STRING - && format == 8) - { - bcopy (data, increment_ptr, items); - increment_ptr += items; - } - } - while (bytes_left); - - } - while (increment_ptr < (increment_value + total_size)); - - return make_string (increment_value, - (increment_ptr - increment_value)); - } - } - - return Qnil; -} - - -/* Cut buffer management. */ - -DEFUN ("x-get-cut-buffer", Fx_get_cut_buffer, Sx_get_cut_buffer, 0, 1, "", - "Return the value of cut buffer N, or nil if it is unset.\n\ -If N is omitted, it defaults to zero.\n\ -Note that cut buffers have some problems that selections don't; try to\n\ -write your code to use cut buffers only for backward compatibility,\n\ -and use selections for the serious work.") - (n) - Lisp_Object n; -{ - int buf_num; - - if (NILP (n)) - buf_num = 0; - else - { - CHECK_NUMBER (n, 0); - buf_num = XINT (n); - } - - if (buf_num < 0 || buf_num >= NUM_CUT_BUFFERS) - error ("cut buffer numbers must be from zero to seven"); - - { - Lisp_Object value; - - /* Note that no PropertyNotify events will be processed while - input is blocked. */ - BLOCK_INPUT; - - if (cut_buffer_cached & (1 << buf_num)) - value = XVECTOR (cut_buffer_value)->contents[buf_num]; - else - { - /* Our cache is invalid; retrieve the property's value from - the server. */ - int buf_len; - char *buf = XFetchBuffer (x_current_display, &buf_len, buf_num); - - if (buf_len == 0) - value = Qnil; - else - value = make_string (buf, buf_len); - - XVECTOR (cut_buffer_value)->contents[buf_num] = value; - cut_buffer_cached |= (1 << buf_num); - - XFree (buf); - } - - UNBLOCK_INPUT; - - return value; - } -} - -DEFUN ("x-set-cut-buffer", Fx_set_cut_buffer, Sx_set_cut_buffer, 2, 2, "", - "Set the value of cut buffer N to STRING.\n\ -Note that cut buffers have some problems that selections don't; try to\n\ -write your code to use cut buffers only for backward compatibility,\n\ -and use selections for the serious work.") - (n, string) - Lisp_Object n, string; -{ - int buf_num; - - CHECK_NUMBER (n, 0); - CHECK_STRING (string, 1); - - buf_num = XINT (n); - - if (buf_num < 0 || buf_num >= NUM_CUT_BUFFERS) - error ("cut buffer numbers must be from zero to seven"); - - BLOCK_INPUT; - - /* DECwindows and some other servers don't seem to like setting - properties to values larger than about 20k. For very large - values, they signal an error, but for intermediate values they - just seem to hang. - - We could just truncate the request, but it's better to let the - user know that the strategy he/she's using isn't going to work - than to have it work partially, but incorrectly. */ - - if (XSTRING (string)->size == 0 - || XSTRING (string)->size > MAX_SELECTION (x_current_display)) - { - XStoreBuffer (x_current_display, (char *) 0, 0, buf_num); - string = Qnil; - } - else - { - XStoreBuffer (x_current_display, - (char *) XSTRING (string)->data, XSTRING (string)->size, - buf_num); - } - - XVECTOR (cut_buffer_value)->contents[buf_num] = string; - cut_buffer_cached |= (1 << buf_num); - cut_buffer_just_set |= (1 << buf_num); - - UNBLOCK_INPUT; - - return string; -} - -/* Ask the server to send us an event if any cut buffer is modified. */ - -void -x_watch_cut_buffer_cache () -{ - XSelectInput (x_current_display, ROOT_WINDOW, PropertyChangeMask); -} - -/* The server has told us that a cut buffer has been modified; deal with that. - Note that this function is called at interrupt level. */ -void -x_invalidate_cut_buffer_cache (XPropertyEvent *event) -{ - int i; - - /* See which cut buffer this is about, if any. */ - for (i = 0; i < NUM_CUT_BUFFERS; i++) - if (event->atom == cut_buffer_atom[i]) - { - int mask = (1 << i); - - if (cut_buffer_just_set & mask) - cut_buffer_just_set &= ~mask; - else - cut_buffer_cached &= ~mask; - - break; - } -} - - -/* Bureaucracy. */ - -void -syms_of_xselect () -{ - DEFVAR_LISP ("x-selection-value", &Vx_selection_value, - "The value of emacs' last cut-string."); - Vx_selection_value = Qnil; - - DEFVAR_LISP ("x-secondary-selection-value", &Vx_secondary_selection_value, - "The value of emacs' last secondary cut-string."); - Vx_secondary_selection_value = Qnil; - - DEFVAR_LISP ("x-clipboard-value", &Vx_clipboard_value, - "The string emacs last sent to the clipboard."); - Vx_clipboard_value = Qnil; - - Qprimary = intern ("primary"); - staticpro (&Qprimary); - Qsecondary = intern ("secondary"); - staticpro (&Qsecondary); - Qclipboard = intern ("clipboard"); - staticpro (&Qclipboard); - - defsubr (&Sx_set_selection); - defsubr (&Sx_selection); - - cut_buffer_value = Fmake_vector (make_number (NUM_CUT_BUFFERS), Qnil); - staticpro (&cut_buffer_value); - - defsubr (&Sx_get_cut_buffer); - defsubr (&Sx_set_cut_buffer); -} -#endif /* X11 */
--- a/src/m/=dos386.h Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,115 +0,0 @@ -/* Machine description file for MS-DOS - - Copyright (C) 1993 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, 675 Mass Ave, Cambridge, MA 02139, USA. */ - -/* Note: lots of stuff here was taken from m-dos386.h in demacs. */ - - -/* The following three symbols give information on - the size of various data types. */ - -#define SHORTBITS 16 /* Number of bits in a short */ -#define INTBITS 32 /* Number of bits in an int */ -#define LONGBITS 32 /* Number of bits in a long */ - -/* Define BIG_ENDIAN iff lowest-numbered byte in a word - is the most significant byte. */ - -/* #define BIG_ENDIAN */ - -/* Define NO_ARG_ARRAY if you cannot take the address of the first of a - * group of arguments and treat it as an array of the arguments. */ - -/* #define NO_ARG_ARRAY */ - -/* Define WORD_MACHINE if addresses and such have - * to be corrected before they can be used as byte counts. */ - -/* #define WORD_MACHINE */ - -/* Define how to take a char and sign-extend into an int. - On machines where char is signed, this is a no-op. */ - -#define SIGN_EXTEND_CHAR(c) (c) - -/* Now define a symbol for the cpu type, if your compiler - does not define it automatically: - Ones defined so far include vax, m68000, ns16000, pyramid, - orion, tahoe, APOLLO and many others */ - -#define INTEL386 - -/* Use type int rather than a union, to represent Lisp_Object */ -/* This is desirable for most machines. */ - -#define NO_UNION_TYPE - -/* Define EXPLICIT_SIGN_EXTEND if XINT must explicitly sign-extend - the 24-bit bit field into an int. In other words, if bit fields - are always unsigned. - - If you use NO_UNION_TYPE, this flag does not matter. */ - -#define EXPLICIT_SIGN_EXTEND - -/* Data type of load average, as read out of kmem. */ - -/* #define LOAD_AVE_TYPE long */ - -/* Convert that into an integer that is 100 for a load average of 1.0 */ - -/* #define LOAD_AVE_CVT(x) (int) (((double) (x)) * 100.0 / FSCALE) */ - -/* Define CANNOT_DUMP on machines where unexec does not work. - Then the function dump-emacs will not be defined - and temacs will do (load "loadup") automatically unless told otherwise. */ - -/* #define CANNOT_DUMP */ - -/* Define VIRT_ADDR_VARIES if the virtual addresses of - pure and impure space as loaded can vary, and even their - relative order cannot be relied on. - - Otherwise Emacs assumes that text space precedes data space, - numerically. */ - -/* #define VIRT_ADDR_VARIES */ - -/* Define C_ALLOCA if this machine does not support a true alloca - and the one written in C should be used instead. - Define HAVE_ALLOCA to say that the system provides a properly - working alloca function and it should be used. - Define neither one if an assembler-language alloca - in the file alloca.s should be used. */ - -#define HAVE_ALLOCA -#define alloca(x) __builtin_alloca(x) - -/* Define NO_REMAP if memory segmentation makes it not work well - to change the boundary between the text section and data section - when Emacs is dumped. If you define this, the preloaded Lisp - code will not be sharable; but that's better than failing completely. */ - -#define NO_REMAP - -/* We need a little extra space, see ../../lisp/loadup.el */ -#define PURESIZE 240000 - -/* We have (the code to control) a mouse. */ -#define HAVE_MOUSE
--- a/tparam.c Thu Jul 05 14:08:30 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,324 +0,0 @@ -/* Merge parameters into a termcap entry string. - Copyright (C) 1985, 87, 93, 95 Free Software Foundation, Inc. - -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, 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; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* Emacs config.h may rename various library functions such as malloc. */ -#ifdef HAVE_CONFIG_H -#include <config.h> -#endif - -#ifndef emacs -#if defined(HAVE_STRING_H) || defined(STDC_HEADERS) -#define bcopy(s, d, n) memcpy ((d), (s), (n)) -#endif - -#ifdef STDC_HEADERS -#include <stdlib.h> -#include <string.h> -#else -char *malloc (); -char *realloc (); -#endif - -#endif /* not emacs */ - -#ifndef NULL -#define NULL (char *) 0 -#endif - -#ifndef emacs -static void -memory_out () -{ - write (2, "virtual memory exhausted\n", 25); - exit (1); -} - -static char * -xmalloc (size) - unsigned size; -{ - register char *tem = malloc (size); - - if (!tem) - memory_out (); - return tem; -} - -static char * -xrealloc (ptr, size) - char *ptr; - unsigned size; -{ - register char *tem = realloc (ptr, size); - - if (!tem) - memory_out (); - return tem; -} -#endif /* not emacs */ - -/* Assuming STRING is the value of a termcap string entry - containing `%' constructs to expand parameters, - merge in parameter values and store result in block OUTSTRING points to. - LEN is the length of OUTSTRING. If more space is needed, - a block is allocated with `malloc'. - - The value returned is the address of the resulting string. - This may be OUTSTRING or may be the address of a block got with `malloc'. - In the latter case, the caller must free the block. - - The fourth and following args to tparam serve as the parameter values. */ - -static char *tparam1 (); - -/* VARARGS 2 */ -char * -tparam (string, outstring, len, arg0, arg1, arg2, arg3) - char *string; - char *outstring; - int len; - int arg0, arg1, arg2, arg3; -{ - int arg[4]; - - arg[0] = arg0; - arg[1] = arg1; - arg[2] = arg2; - arg[3] = arg3; - return tparam1 (string, outstring, len, NULL, NULL, arg); -} - -char *BC; -char *UP; - -static char tgoto_buf[50]; - -char * -tgoto (cm, hpos, vpos) - char *cm; - int hpos, vpos; -{ - int args[2]; - if (!cm) - return NULL; - args[0] = vpos; - args[1] = hpos; - return tparam1 (cm, tgoto_buf, 50, UP, BC, args); -} - -static char * -tparam1 (string, outstring, len, up, left, argp) - char *string; - char *outstring; - int len; - char *up, *left; - register int *argp; -{ - register int c; - register char *p = string; - register char *op = outstring; - char *outend; - int outlen = 0; - - register int tem; - int *old_argp = argp; - int doleft = 0; - int doup = 0; - - outend = outstring + len; - - while (1) - { - /* If the buffer might be too short, make it bigger. */ - if (op + 5 >= outend) - { - register char *new; - if (outlen == 0) - { - outlen = len + 40; - new = (char *) xmalloc (outlen); - outend += 40; - bcopy (outstring, new, op - outstring); - } - else - { - outend += outlen; - outlen *= 2; - new = (char *) xrealloc (outstring, outlen); - } - op += new - outstring; - outend += new - outstring; - outstring = new; - } - c = *p++; - if (!c) - break; - if (c == '%') - { - c = *p++; - tem = *argp; - switch (c) - { - case 'd': /* %d means output in decimal. */ - if (tem < 10) - goto onedigit; - if (tem < 100) - goto twodigit; - case '3': /* %3 means output in decimal, 3 digits. */ - if (tem > 999) - { - *op++ = tem / 1000 + '0'; - tem %= 1000; - } - *op++ = tem / 100 + '0'; - case '2': /* %2 means output in decimal, 2 digits. */ - twodigit: - tem %= 100; - *op++ = tem / 10 + '0'; - onedigit: - *op++ = tem % 10 + '0'; - argp++; - break; - - case 'C': - /* For c-100: print quotient of value by 96, if nonzero, - then do like %+. */ - if (tem >= 96) - { - *op++ = tem / 96; - tem %= 96; - } - case '+': /* %+x means add character code of char x. */ - tem += *p++; - case '.': /* %. means output as character. */ - if (left) - { - /* If want to forbid output of 0 and \n and \t, - and this is one of them, increment it. */ - while (tem == 0 || tem == '\n' || tem == '\t') - { - tem++; - if (argp == old_argp) - doup++, outend -= strlen (up); - else - doleft++, outend -= strlen (left); - } - } - *op++ = tem ? tem : 0200; - case 'f': /* %f means discard next arg. */ - argp++; - break; - - case 'b': /* %b means back up one arg (and re-use it). */ - argp--; - break; - - case 'r': /* %r means interchange following two args. */ - argp[0] = argp[1]; - argp[1] = tem; - old_argp++; - break; - - case '>': /* %>xy means if arg is > char code of x, */ - if (argp[0] > *p++) /* then add char code of y to the arg, */ - argp[0] += *p; /* and in any case don't output. */ - p++; /* Leave the arg to be output later. */ - break; - - case 'a': /* %a means arithmetic. */ - /* Next character says what operation. - Add or subtract either a constant or some other arg. */ - /* First following character is + to add or - to subtract - or = to assign. */ - /* Next following char is 'p' and an arg spec - (0100 plus position of that arg relative to this one) - or 'c' and a constant stored in a character. */ - tem = p[2] & 0177; - if (p[1] == 'p') - tem = argp[tem - 0100]; - if (p[0] == '-') - argp[0] -= tem; - else if (p[0] == '+') - argp[0] += tem; - else if (p[0] == '*') - argp[0] *= tem; - else if (p[0] == '/') - argp[0] /= tem; - else - argp[0] = tem; - - p += 3; - break; - - case 'i': /* %i means add one to arg, */ - argp[0] ++; /* and leave it to be output later. */ - argp[1] ++; /* Increment the following arg, too! */ - break; - - case '%': /* %% means output %; no arg. */ - goto ordinary; - - case 'n': /* %n means xor each of next two args with 140. */ - argp[0] ^= 0140; - argp[1] ^= 0140; - break; - - case 'm': /* %m means xor each of next two args with 177. */ - argp[0] ^= 0177; - argp[1] ^= 0177; - break; - - case 'B': /* %B means express arg as BCD char code. */ - argp[0] += 6 * (tem / 10); - break; - - case 'D': /* %D means weird Delta Data transformation. */ - argp[0] -= 2 * (tem % 16); - break; - } - } - else - /* Ordinary character in the argument string. */ - ordinary: - *op++ = c; - } - *op = 0; - while (doup-- > 0) - strcat (op, up); - while (doleft-- > 0) - strcat (op, left); - return outstring; -} - -#ifdef DEBUG - -main (argc, argv) - int argc; - char **argv; -{ - char buf[50]; - int args[3]; - args[0] = atoi (argv[2]); - args[1] = atoi (argv[3]); - args[2] = atoi (argv[4]); - tparam1 (argv[1], buf, "LEFT", "UP", args); - printf ("%s\n", buf); - return 0; -} - -#endif /* DEBUG */