(font-lock-keywords): Docstring fixes.
[bpt/emacs.git] / lisp / textmodes / table.el
CommitLineData
238240c9
RS
1;;; table.el --- create and edit WYSIWYG text based embedded tables
2
951f97e6
SM
3;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005
4;; Free Software Foundation, Inc.
238240c9
RS
5
6;; Keywords: wp, convenience
7;; Author: Takaaki Ota <Takaaki.Ota@am.sony.com>
8;; Created: Sat Jul 08 2000 13:28:45 (PST)
951f97e6 9;; Revised: Fri Mar 18 2005 13:50:13 (PST)
238240c9
RS
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software; you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation; either version 2, or (at your option)
16;; any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs; see the file COPYING. If not, write to the
25;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;; Boston, MA 02111-1307, USA.
27
28;;; Commentary:
29
30;; -------------
31;; Introduction:
32;; -------------
33;;
34;; This package provides text based table creation and editing
35;; feature. With this package Emacs is capable of editing tables that
36;; are embedded inside a text document, the feature similar to the
37;; ones seen in modern WYSIWYG word processors. A table is a
38;; rectangular text area consisting from a surrounding frame and
39;; content inside the frame. The content is usually subdivided into
40;; multiple rectangular cells, see the actual tables used below in
41;; this document. Once a table is recognized, editing operation
42;; inside a table cell is confined into that specific cell's
43;; rectangular area. This means that typing and deleting characters
44;; inside a cell do not affect any outside text but introduces
45;; appropriate formatting only to the cell contents. If necessary for
46;; accommodating added text in the cell, the cell automatically grows
47;; vertically and/or horizontally. The package uses no major mode nor
48;; minor mode for its implementation because the subject text is
49;; localized within a buffer. Therefore the special behaviors inside
50;; a table cells are implemented by using keymap text property
51;; instead of buffer wide mode-map.
52;;
53;;
54;; -----------
55;; Background:
56;; -----------
57;;
58;; Paul Georgief is one of my best friends. He became an Emacs
59;; convert after I recommended him trying it several years ago. Now
60;; we both are devoted disciples of Emacsism and elisp cult. One day
61;; in his Emacs exploration he asked me "Tak, what is a command to
62;; edit tables in Emacs?". This question started my journey of this
63;; table package development. May the code be with me! In the
64;; software world Emacs is probably one of the longest lifetime record
65;; holders. Amazingly there have been no direct support for WYSIWYG
66;; table editing tasks in Emacs. Many people must have experienced
67;; manipulating existing overwrite-mode and picture-mode for this task
68;; and only dreamed of having such a lisp package which supports this
69;; specific task directly. Certainly, I have been one of them. The
70;; most difficult part of dealing with table editing in Emacs probably
71;; is how to realize localized rectangular editing effect. Emacs has
72;; no rectangular narrowing mechanism. Existing rect package provides
73;; basically kill, delete and yank operations of a rectangle, which
74;; internally is a mere list of strings. A simple approach for
75;; realizing the localized virtual rectangular operation is combining
76;; rect package capability with a temporary buffer. Insertion and
77;; deletion of a character to a table cell can be trapped by a
78;; function that copies the cell rectangle to a temporary buffer then
79;; apply the insertion/deletion to the temporary contents. Then it
80;; formats the contents by filling the paragraphs in order to fit it
81;; into the original rectangular area and finally copy it back to the
82;; original buffer. This simplistic approach has to bear with
83;; significant performance hit. As cell grows larger the copying
84;; rectangle back and forth between the original buffer and the
85;; temporary buffer becomes expensive and unbearably slow. It was
86;; completely impractical and an obvious failure. An idea has been
87;; borrowed from the original Emacs design to overcome this
88;; shortcoming. When the terminal screen update was slow and
89;; expensive Emacs employed a clever algorithm to reduce actual screen
90;; update by removing redundant redrawing operations. Also the actual
91;; redrawing was done only when there was enough idling time. This
92;; technique significantly improved the previously mentioned
93;; undesirable situation. Now the original buffer's rectangle is
94;; copied into a cache buffer only once. Any cell editing operation
95;; is done only to the cache contents. When there is enough idling
96;; time the original buffer's rectangle is updated with the current
97;; cache contents. This delayed operation is implemented by using
98;; Emacs's timer function. To reduce the visual awkwardness
99;; introduced by the delayed effect the cursor location is updated in
100;; real-time as a user types while the cell contents remains the same
101;; until the next idling time. A key to the success of this approach
102;; is how to maintain cache coherency. As a user moves point in and
103;; out of a cell the table buffer contents and the cache buffer
104;; contents must be synchronized without a mistake. By observing user
105;; action carefully this is possible however not easy. Once this
106;; mechanism is firmly implemented the rest of table features grew in
107;; relatively painless progression. Those users who are familiar with
108;; Emacs internals appreciate this table package more. Because it
109;; demonstrates how extensible Emacs is by showing something that
110;; appears like a magic. It lets you re-discover the potential of
111;; Emacs.
112;;
113;;
114;; -------------
115;; Entry Points:
116;; -------------
117;;
118;; If this is the first time for you to try this package, go ahead and
119;; load the package by M-x `load-file' RET. Specify the package file
120;; name "table.el". Then switch to a new test buffer and issue the
121;; command M-x `table-insert' RET. It'll ask you number of columns,
122;; number of rows, cell width and cell height. Give some small
123;; numbers for each of them. Play with the resulted table for a
124;; while. If you have menu system find the item "Table" under "Tools"
125;; and "Table" in the menu bar when the point is in a table cell.
126;; Some of them are pretty intuitive and you can easily guess what
127;; they do. M-x `describe-function' and get the documentation of
128;; `table-insert'. The document includes a short tutorial. When you
129;; are tired of guessing how it works come back to this document
130;; again.
131;;
132;; To use the package regularly place this file in the site library
133;; directory and add the next expression in your .emacs file. Make
134;; sure that directory is included in the `load-path'.
135;;
136;; (require 'table)
137;;
138;; Have the next expression also, if you want always be ready to edit
139;; tables inside text files. This mechanism is analogous to
140;; fontification in a sense that tables are recognized at editing time
141;; without having table information saved along with the text itself.
142;;
143;; (add-hook 'text-mode-hook 'table-recognize)
144;;
145;; Following is a table of entry points and brief description of each
146;; of them. The tables below are of course generated and edited by
147;; using this package. Not all the commands are bound to keys. Many
148;; of them must be invoked by "M-x" (`execute-extended-command')
149;; command. Refer to the section "Keymap" below for the commands
150;; available from keys.
151;;
152;; +------------------------------------------------------------------+
153;; | User Visible Entry Points |
154;; +-------------------------------+----------------------------------+
155;; | Function | Description |
156;; +-------------------------------+----------------------------------+
157;; |`table-insert' |Insert a table consisting of grid |
158;; | |of cells by specifying the number |
159;; | |of COLUMNS, number of ROWS, cell |
160;; | |WIDTH and cell HEIGHT. |
161;; +-------------------------------+----------------------------------+
162;; |`table-insert-row' |Insert row(s) of cells before the |
163;; | |current row that matches the |
164;; | |current row structure. |
165;; +-------------------------------+----------------------------------+
166;; |`table-insert-column' |Insert column(s) of cells before |
167;; | |the current column that matches |
168;; | |the current column structure. |
169;; +-------------------------------+----------------------------------+
170;; |`table-delete-row' |Delete row(s) of cells. The row |
171;; | |must consist from cells of the |
172;; | |same height. |
173;; +-------------------------------+----------------------------------+
174;; |`table-delete-column' |Delete column(s) of cells. The |
175;; | |column must consist from cells of |
176;; | |the same width. |
177;; +-------------------------------+----------------------------------+
178;; |`table-recognize' |Recognize all tables in the |
179;; |`table-unrecognize' |current buffer and |
180;; | |activate/inactivate them. |
181;; +-------------------------------+----------------------------------+
182;; |`table-recognize-region' |Recognize all the cells in a |
183;; |`table-unrecognize-region' |region and activate/inactivate |
184;; | |them. |
185;; +-------------------------------+----------------------------------+
186;; |`table-recognize-table' |Recognize all the cells in a |
187;; |`table-unrecognize-table' |single table and |
188;; | |activate/inactivate them. |
189;; +-------------------------------+----------------------------------+
190;; |`table-recognize-cell' |Recognize a cell. Find a cell |
191;; |`table-unrecognize-cell' |which contains the current point |
192;; | |and activate/inactivate that cell.|
193;; +-------------------------------+----------------------------------+
194;; |`table-forward-cell' |Move point to the next Nth cell in|
195;; | |a table. |
196;; +-------------------------------+----------------------------------+
197;; |`table-backward-cell' |Move point to the previous Nth |
198;; | |cell in a table. |
199;; +-------------------------------+----------------------------------+
200;; |`table-span-cell' |Span the current cell toward the |
201;; | |specified direction and merge it |
202;; | |with the adjacent cell. The |
203;; | |direction is right, left, above or|
204;; | |below. |
205;; +-------------------------------+----------------------------------+
206;; |`table-split-cell-vertically' |Split the current cell vertically |
207;; | |and create a cell above and a cell|
208;; | |below the point location. |
209;; +-------------------------------+----------------------------------+
210;; |`table-split-cell-horizontally'|Split the current cell |
211;; | |horizontally and create a cell on |
212;; | |the left and a cell on the right |
213;; | |of the point location. |
214;; +-------------------------------+----------------------------------+
215;; |`table-split-cell' |Split the current cell vertically |
216;; | |or horizontally. This is a |
217;; | |wrapper command to the other two |
218;; | |orientation specific commands. |
219;; +-------------------------------+----------------------------------+
220;; |`table-heighten-cell' |Heighten the current cell. |
221;; +-------------------------------+----------------------------------+
222;; |`table-shorten-cell' |Shorten the current cell. |
223;; +-------------------------------+----------------------------------+
224;; |`table-widen-cell' |Widen the current cell. |
225;; +-------------------------------+----------------------------------+
226;; |`table-narrow-cell' |Narrow the current cell. |
227;; +-------------------------------+----------------------------------+
228;; |`table-fixed-width-mode' |Toggle fixed width mode. In the |
229;; | |fixed width mode, typing inside a |
230;; | |cell never changes the cell width,|
231;; | |while in the normal mode the cell |
232;; | |width expands automatically in |
233;; | |order to prevent a word being |
234;; | |folded into multiple lines. Fixed|
235;; | |width mode reverses video or |
236;; | |underline the cell contents for |
237;; | |its indication. |
238;; +-------------------------------+----------------------------------+
239;; |`table-query-dimension' |Compute and report the current |
240;; | |cell dimension, current table |
241;; | |dimension and the number of |
242;; | |columns and rows in the table. |
243;; +-------------------------------+----------------------------------+
244;; |`table-generate-source' |Generate the source of the current|
245;; | |table in the specified language |
246;; | |and insert it into a specified |
247;; | |buffer. |
248;; +-------------------------------+----------------------------------+
249;; |`table-insert-sequence' |Travel cells forward while |
250;; | |inserting a specified sequence |
251;; | |string into each cell. |
252;; +-------------------------------+----------------------------------+
253;; |`table-capture' |Convert plain text into a table by|
254;; | |capturing the text in the region. |
255;; +-------------------------------+----------------------------------+
256;; |`table-release' |Convert a table into plain text by|
257;; | |removing the frame from a table. |
258;; +-------------------------------+----------------------------------+
259;; |`table-justify' |Justify the contents of cell(s). |
260;; +-------------------------------+----------------------------------+
261;;
262;;
263;; *Note*
264;;
265;; You may find that some of commonly expected table commands are
266;; missing such as copying a row/column and yanking it. Those
267;; functions can be obtained through existing Emacs text editing
268;; commands. Rows are easily manipulated with region commands and
269;; columns can be copied and pasted through rectangle commands. After
270;; all a table is still a part of text in the buffer. Only the
271;; special behaviors exist inside each cell through text properties.
272;;
273;; `table-generate-html' which appeared in earlier releases is
274;; deprecated in favor of `table-generate-source'. Now HTML is
275;; treated as one of the languages used for describing the table's
276;; logical structure.
277;;
278;;
279;; -------
280;; Keymap:
281;; -------
282;;
283;; Although this package does not use a mode it does use its own
284;; keymap inside a table cell by way of keymap text property. Some of
285;; the standard basic editing commands bound to certain keys are
286;; replaced with the table specific version of corresponding commands.
287;; This replacement combination is listed in the constant alist
288;; `table-command-remap-alist' declared below. This alist is
289;; not meant to be user configurable but mentioned here for your
290;; better understanding of using this package. In addition, table
291;; cells have some table specific bindings for cell navigation and
292;; cell reformation. You can find these additional bindings in the
293;; constant `table-cell-bindings'. Those key bound functions are
294;; considered as internal functions instead of normal commands,
295;; therefore they have special prefix, *table-- instead of table-, for
296;; symbols. The purpose of this is to make it easier for a user to
297;; use command name completion. There is a "normal hooks" variable
298;; `table-cell-map-hook' prepared for users to override the default
299;; table cell bindings. Following is the table of predefined default
300;; key bound commands inside a table cell. Remember these bindings
301;; exist only inside a table cell. When your terminal is a tty, the
302;; control modifier may not be available or applicable for those
303;; special characters. In this case use "C-cC-c", which is
304;; customizable via `table-command-prefix', as the prefix key
305;; sequence. This should preceding the following special character
306;; without the control modifier. For example, use "C-cC-c|" instead
307;; of "C-|".
308;;
309;; +------------------------------------------------------------------+
310;; | Default Bindings in a Table Cell |
311;; +-------+----------------------------------------------------------+
312;; | Key | Function |
313;; +-------+----------------------------------------------------------+
314;; | TAB |Move point forward to the beginning of the next cell. |
315;; +-------+----------------------------------------------------------+
316;; | "C->" |Widen the current cell. |
317;; +-------+----------------------------------------------------------+
318;; | "C-<" |Narrow the current cell. |
319;; +-------+----------------------------------------------------------+
320;; | "C-}" |Heighten the current cell. |
321;; +-------+----------------------------------------------------------+
322;; | "C-{" |Shorten the current cell. |
323;; +-------+----------------------------------------------------------+
324;; | "C--" |Split current cell vertically. (one above and one below) |
325;; +-------+----------------------------------------------------------+
326;; | "C-|" |Split current cell horizontally. (one left and one right) |
327;; +-------+----------------------------------------------------------+
328;; | "C-*" |Span current cell into adjacent one. |
329;; +-------+----------------------------------------------------------+
330;; | "C-+" |Insert row(s)/column(s). |
331;; +-------+----------------------------------------------------------+
332;; | "C-!" |Toggle between normal mode and fixed width mode. |
333;; +-------+----------------------------------------------------------+
334;; | "C-#" |Report cell and table dimension. |
335;; +-------+----------------------------------------------------------+
336;; | "C-^" |Generate the source in a language from the current table. |
337;; +-------+----------------------------------------------------------+
338;; | "C-:" |Justify the contents of cell(s). |
339;; +-------+----------------------------------------------------------+
340;;
341;; *Note*
342;;
343;; When using `table-cell-map-hook' do not use `local-set-key'.
344;;
345;; (add-hook 'table-cell-map-hook
346;; (function (lambda ()
347;; (local-set-key [<key sequence>] '<function>))))
348;;
349;; Above code is well known ~/.emacs idiom for customizing a mode
350;; specific keymap however it does not work for this package. This is
351;; because there is no table mode in effect. This package does not
352;; use a local map therefor you must modify `table-cell-map'
353;; explicitly. The correct way of achieving above task is:
354;;
355;; (add-hook 'table-cell-map-hook
356;; (function (lambda ()
357;; (define-key table-cell-map [<key sequence>] '<function>))))
358;;
359;; -----
360;; Menu:
361;; -----
362;;
363;; If a menu system is available a group of table specific menu items,
364;; "Table" under "Tools" section of the menu bar, is globally added
365;; after this package is loaded. The commands in this group are
366;; limited to the ones that are related to creation and initialization
367;; of tables, such as to insert a table, to insert rows and columns,
368;; or recognize and unrecognize tables. Once tables are created and
369;; point is placed inside of a table cell a table specific menu item
370;; "Table" appears directly on the menu bar. The commands in this
371;; menu give full control on table manipulation that include cell
372;; navigation, insertion, splitting, spanning, shrinking, expansion
373;; and unrecognizing. In addition to above two types of menu there is
374;; a pop-up menu available within a table cell. The content of pop-up
375;; menu is identical to the full table menu. [mouse-3] is the default
376;; button, defined in `table-cell-bindings', to bring up the pop-up
377;; menu. It can be reconfigured via `table-cell-map-hook'. The
378;; benefit of a pop-up menu is that it combines selection of the
379;; location (which cell, where in the cell) and selection of the
380;; desired operation into a single clicking action.
381;;
382;;
383;; -------------------------------
384;; Definition of tables and cells:
385;; -------------------------------
386;;
387;; There is no artificial-intelligence magic in this package. The
388;; definition of a table and the cells inside the table is reasonably
389;; limited in order to achieve acceptable performance in the
390;; interactive operation under Emacs lisp implementation. A valid
391;; table is a rectangular text area completely filled with valid
392;; cells. A valid cell is a rectangle text area, which four borders
393;; consist of valid border characters. Cells can not be nested one to
394;; another or overlapped to each other except sharing the border
395;; lines. A valid character of a cell's vertical border is either
396;; table-cell-vertical-char `|' or table-cell-intersection-char `+'.
397;; A valid character of a cell's horizontal border is either
398;; table-cell-horizontal-char `-' or table-cell-intersection-char `+'.
399;; A valid character of the four corners of a cell must be
400;; table-cell-intersection-char `+'. A cell must contain at least one
401;; character space inside. There is no restriction about the contents
402;; of a table cell, however it is advised if possible to avoid using
403;; any of the border characters inside a table cell. Normally a few
404;; boarder characters inside a table cell are harmless. But it is
405;; possible that they accidentally align up to emulate a bogus cell
406;; corner on which software relies on for cell recognition. When this
407;; happens the software may be fooled by it and fail to determine
408;; correct cell dimension.
409;;
410;; Following are the examples of valid tables.
411;;
412;; +--+----+---+ +-+ +--+-----+
413;; | | | | | | | | |
414;; +--+----+---+ +-+ | +--+--+
415;; | | | | | | | |
416;; +--+----+---+ +--+--+ |
417;; | | |
418;; +-----+--+
419;;
420;; The next five tables are the examples of invalid tables. (From
421;; left to right, 1. nested cells 2. overlapped cells and a
422;; non-rectangle cell 3. non-rectangle table 4. zero width/height
423;; cells 5. zero sized cell)
424;;
425;; +-----+ +-----+ +--+ +-++--+ ++
426;; | | | | | | | || | ++
427;; | +-+ | | | | | | || |
428;; | | | | +--+ | +--+--+ +-++--+
429;; | +-+ | | | | | | | +-++--+
430;; | | | | | | | | | || |
431;; +-----+ +--+--+ +--+--+ +-++--+
432;;
433;; Although the program may recognizes some of these invalid tables,
434;; results from the subsequent editing operations inside those cells
435;; are not predictable and will most likely start destroying the table
436;; structures.
437;;
438;; It is strongly recommended to have at least one blank line above
439;; and below a table. For a table to coexist peacefully with
440;; surrounding environment table needs to be separated from unrelated
441;; text. This is necessary for the left table to grow or shrink
442;; horizontally without breaking the right table in the following
443;; example.
444;;
445;; +-----+-----+-----+
446;; +-----+-----+ | | | |
447;; | | | +-----+-----+-----+
448;; +-----+-----+ | | | |
449;; +-----+-----+-----+
450;;
451;;
452;; -------------------------
453;; Cell contents formatting:
454;; -------------------------
455;;
456;; The cell contents are formatted by filling a paragraph immediately
457;; after characters are inserted into or deleted from a cell. Because
458;; of this, cell contents always remain fit inside a cell neatly. One
459;; drawback of this is that users do not have full control over
460;; spacing between words and line breaking. Only one space can be
461;; entered between words and up to two spaces between sentences. For
462;; a newline to be effective the new line must form a beginning of
463;; paragraph, otherwise it'll automatically be merged with the
464;; previous line in a same paragraph. To form a new paragraph the
465;; line must start with some space characters or immediately follow a
466;; blank line. Here is a typical example of how to list items within
467;; a cell. Without a space at the beginning of each line the items
468;; can not stand on their own.
469;;
470;; +---------------------------------+
471;; |Each one of the following three |
472;; |items starts with a space |
473;; |character thus forms a paragraph |
474;; |of its own. Limitations in cell |
475;; |contents formatting are: |
476;; | |
477;; | 1. Only one space between words.|
478;; | 2. Up to two spaces between |
479;; |sentences. |
480;; | 3. A paragraph must start with |
481;; |spaces or follow a blank line. |
482;; | |
483;; |This paragraph stays away from |
484;; |the item 3 because there is a |
485;; |blank line between them. |
486;; +---------------------------------+
487;;
488;; In the normal operation table cell width grows automatically when
489;; certain word has to be folded into the next line if the width had
490;; not been increased. This normal operation is useful and
491;; appropriate for most of the time, however, it is sometimes useful
492;; or necessary to fix the width of table and width of table cells.
493;; For this purpose the package provides fixed width mode. You can
494;; toggle between fixed width mode and normal mode by "C-!".
495;;
496;; Here is a simple example of the fixed width mode. Suppose we have
497;; a table like this one.
498;;
499;; +-----+
500;; | |
501;; +-----+
502;;
503;; In normal mode if you type a word "antidisestablishmentarianism" it
504;; grows the cell horizontally like this.
505;;
506;; +----------------------------+
507;; |antidisestablishmentarianism|
508;; +----------------------------+
509;;
510;; In the fixed width mode the same action produces the following
511;; result. The folded locations are indicated by a continuation
512;; character (`\' is the default). The continuation character is
513;; treated specially so it is recommended to choose a character that
514;; does not appear elsewhere in table cells. This character is
515;; configurable via customization and is kept in the variable
516;; `table-word-continuation-char'. The continuation character is
517;; treated specially only in the fixed width mode and has no special
518;; meaning in the normal mode however.
519;;
520;; +-----+
521;; |anti\|
522;; |dise\|
523;; |stab\|
524;; |lish\|
525;; |ment\|
526;; |aria\|
527;; |nism |
528;; +-----+
529;;
530;;
531;; -------------------
532;; Cell Justification:
533;; -------------------
534;;
535;; By default the cell contents are filled with left justification and
536;; no vertical justification. A paragraph can be justified
537;; individually but only horizontally. Paragraph justification is for
538;; appearance only and does not change any structural information
539;; while cell justification affects table's structural information.
540;; For cell justification a user can select horizontal justification
541;; and vertical justification independently. Horizontal justification
542;; must be one of the three 'left, 'center or 'right. Vertical
543;; justification can be 'top, 'middle, 'bottom or 'none. When a cell
544;; is justified, that information is recorded as a part of text
545;; property therefore the information is persistent as long as the
546;; cell remains within the Emacs world. Even copying tables by region
547;; and rectangle manipulation commands preserve this information.
548;; However, once the table text is saved as a file and the buffer is
549;; killed the justification information vanishes permanently. To
550;; alleviate this shortcoming without forcing users to save and
551;; maintain a separate attribute file, the table code detects
552;; justification of each cell when recognizing a table. This
553;; detection is done by guessing the justification by looking at the
554;; appearance of the cell contents. Since it is a guessing work it
555;; does not guarantee the perfectness but it is designed to be
556;; practically good enough. The guessing algorithm is implemented in
557;; the function `table--detect-cell-alignment'. If you have better
558;; algorithm or idea any suggestion is welcome.
559;;
560;;
561;; -----
562;; Todo: (in the order of priority, some are just possibility)
563;; -----
564;;
565;; Fix compatibilities with other input method than quail
566;; Resolve conflict with flyspell
567;; Use mouse for resizing cells
568;; A mechanism to link cells internally
569;; Consider the use of variable width font under Emacs 21
570;; Consider the use of `:box' face attribute under Emacs 21
571;; Consider the use of `modification-hooks' text property instead of
572;; rebinding the keymap
573;; Maybe provide complete XEmacs support in the future however the
574;; "extent" is the single largest obstacle lying ahead, read the
575;; document in Emacs info.
576;; (eval '(progn (require 'info) (Info-find-node "elisp" "Not Intervals")))
577;;
578;;
579;; ---------------
580;; Acknowledgment:
581;; ---------------
582;;
583;; Table would not have been possible without the help and
584;; encouragement of the following spirited contributors.
585;;
586;; Paul Georgief <georgief@igpp.ucsd.edu> has been the best tester
587;; of the code as well as the constructive criticizer.
588;;
589;; Gerd Moellmann <gerd@gnu.org> gave me useful suggestions from Emacs
590;; 21 point of view.
591;;
592;; Richard Stallman <rms@gnu.org> showed the initial interest in this
593;; attempt of implementing the table feature to Emacs. This greatly
594;; motivated me to follow through to its completion.
595;;
596;; Kenichi Handa <handa@etl.go.jp> kindly guided me through to
597;; overcome many technical issues while I was struggling with quail
598;; related internationalization problems.
599;;
600;; Christoph Conrad <christoph.conrad@gmx.de> suggested making symbol
601;; names consistent as well as fixing several bugs.
602;;
603;; Paul Lew <paullew@cisco.com> suggested implementing fixed width
604;; mode as well as multi column width (row height) input interface.
605;;
606;; Michael Smith <smith@xml-doc.org> a well-informed DocBook user
607;; asked for CALS table source generation and helped me following
608;; through the work by offering valuable suggestions and testing out
609;; the code. Jorge Godoy <godoy@conectiva.com> has also suggested
610;; supporting for DocBook tables.
611;;
612;; And many other individuals who reported bugs and suggestions.
613
614;;; Code:
615
616\f
617
618;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
619;;;
620;;; Compatibility:
621;;;
622
623;; hush up the byte-compiler
624(eval-when-compile
625 (defvar quail-translating)
626 (defvar quail-converting)
627 (defvar flyspell-mode)
628 (defvar real-last-command)
629 (defvar delete-selection-mode)
630 (unless (fboundp 'set-face-property)
631 (defun set-face-property (face prop value)))
632 (unless (fboundp 'unibyte-char-to-multibyte)
633 (defun unibyte-char-to-multibyte (char)))
634 (defun table--point-in-cell-p (&optional location)))
635
636;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
637;;;
638;;; Customization:
639;;;
640
641(defgroup table nil
642 "Text based table manipulation utilities.
643See `table-insert' for examples about how to use."
644 :tag "Table"
645 :prefix "table-"
646 :group 'editing
647 :group 'wp
648 :group 'paragraphs
83650443 649 :group 'fill
bf247b6e 650 :version "22.1")
238240c9 651
23179a73
MR
652(defgroup table-hooks nil
653 "Hooks for table manipulation utilities"
654 :group 'table)
655
238240c9
RS
656(defcustom table-time-before-update 0.2
657 "*Time in seconds before updating the cell contents after typing.
658Updating the cell contents on the screen takes place only after this
659specified amount of time has passed after the last modification to the
660cell contents. When the contents of a table cell changes repetitively
661and frequently the updating the cell contents on the screen is
662deferred until at least this specified amount of quiet time passes. A
663smaller number wastes more computation resource by unnecessarily
664frequent screen update. A large number presents noticeable and
665annoying delay before the typed result start appearing on the screen."
666 :tag "Time Before Cell Update"
667 :type 'number
668 :group 'table)
669
670(defcustom table-time-before-reformat 0.2
671 "*Time in seconds before reformatting the table.
672This many seconds must pass in addition to `table-time-before-update'
673before the table is updated with newly widened width or heightened
674height."
675 :tag "Time Before Cell Reformat"
676 :type 'number
677 :group 'table)
678
679(defcustom table-command-prefix [(control c) (control c)]
680 "*Key sequence to be used as prefix for table command key bindings."
790f437c 681 :type '(vector (repeat :inline t sexp))
238240c9
RS
682 :tag "Table Command Prefix"
683 :group 'table)
684
685(defface table-cell-face
686 '((((class color))
687 (:foreground "gray90" :background "blue"))
688 (t (:bold t)))
689 "*Face used for table cell contents."
690 :tag "Cell Face"
691 :group 'table)
692
e99add21
JB
693(defcustom table-cell-horizontal-chars "-="
694 "*Characters that may be used for table cell's horizontal border line."
695 :tag "Cell Horizontal Boundary Characters"
696 :type 'string
238240c9
RS
697 :group 'table)
698
699(defcustom table-cell-vertical-char ?\|
700 "*Character that forms table cell's vertical border line."
701 :tag "Cell Vertical Boundary Character"
702 :type 'character
703 :group 'table)
704
705(defcustom table-cell-intersection-char ?\+
706 "*Character that forms table cell's corner."
707 :tag "Cell Intersection Character"
708 :type 'character
709 :group 'table)
710
711(defcustom table-word-continuation-char ?\\
712 "*Character that indicates word continuation into the next line.
713This character has a special meaning only in the fixed width mode,
714that is when `table-fixed-width-mode' is non-nil . In the fixed width
715mode this character indicates that the location is continuing into the
716next line. Be careful about the choice of this character. It is
717treated substantially different manner than ordinary characters. Try
718select a character that is unlikely to appear in your document."
719 :tag "Cell Word Continuation Character"
720 :type 'character
721 :group 'table)
722
723(defun table-set-table-fixed-width-mode (variable value)
724 (if (fboundp variable)
725 (funcall variable (if value 1 -1))))
726
727(defun table-initialize-table-fixed-width-mode (variable value)
728 (set variable value))
729
730(defcustom table-fixed-width-mode nil
731 "*Cell width is fixed when this is non-nil.
732Normally it should be nil for allowing automatic cell width expansion
733that widens a cell when it is necessary. When non-nil, typing in a
734cell does not automatically expand the cell width. A word that is too
735long to fit in a cell is chopped into multiple lines. The chopped
736location is indicated by `table-word-continuation-char'. This
737variable's value can be toggled by \\[table-fixed-width-mode] at
738run-time."
739 :tag "Fix Cell Width"
740 :type 'boolean
741 :initialize 'table-initialize-table-fixed-width-mode
742 :set 'table-set-table-fixed-width-mode
743 :group 'table)
744
745(defcustom table-detect-cell-alignment t
746 "*Detect cell contents alignment automatically.
747When non-nil cell alignment is automatically determined by the
748appearance of the current cell contents when recognizing tables as a
749whole. This applies to `table-recognize', `table-recognize-region'
750and `table-recognize-table' but not to `table-recognize-cell'."
751 :tag "Detect Cell Alignment"
752 :type 'boolean
753 :group 'table)
754
755(defcustom table-dest-buffer-name "table"
756 "*Default buffer name (without a suffix) for source generation."
757 :tag "Source Buffer Name"
758 :type 'string
759 :group 'table)
760
761(defcustom table-html-delegate-spacing-to-user-agent nil
762 "*Non-nil delegates cell contents spacing entirely to user agent.
763Otherwise, when nil, it preserves the original spacing and line breaks."
764 :tag "HTML delegate spacing"
765 :type 'boolean
766 :group 'table)
767
768(defcustom table-html-th-rows 0
769 "*Number of top rows to become header cells automatically in HTML generation."
770 :tag "HTML Header Rows"
771 :type 'integer
772 :group 'table)
773
774(defcustom table-html-th-columns 0
775 "*Number of left columns to become header cells automatically in HTML generation."
776 :tag "HTML Header Columns"
777 :type 'integer
778 :group 'table)
779
780(defcustom table-html-table-attribute "border=\"1\""
781 "*Table attribute that applies to the table in HTML generation."
782 :tag "HTML table attribute"
783 :type 'string
784 :group 'table)
785
786(defcustom table-html-cell-attribute ""
787 "*Cell attribute that applies to all cells in HTML generation.
788Do not specify \"align\" and \"valign\" because they are determined by
789the cell contents dynamically."
790 :tag "HTML cell attribute"
791 :type 'string
792 :group 'table)
793
794(defcustom table-cals-thead-rows 1
795 "*Number of top rows to become header rows in CALS table."
796 :tag "CALS Header Rows"
797 :type 'integer
798 :group 'table)
799
800;;;###autoload
801(defcustom table-cell-map-hook nil
802 "*Normal hooks run when finishing construction of `table-cell-map'.
803User can modify `table-cell-map' by adding custom functions here."
804 :tag "Cell Keymap Hooks"
805 :type 'hook
23179a73 806 :group 'table-hooks)
238240c9
RS
807
808(defcustom table-disable-incompatibility-warning nil
809 "*Disable compatibility warning notice.
810When nil user is reminded of known incompatible issues."
811 :tag "Disable Incompatibility Warning"
812 :type 'boolean
813 :group 'table)
814
815(defcustom table-abort-recognition-when-input-pending t
816 "*Abort current recognition process when input pending.
817Abort current recognition process when we are not sure that no input
818is available. When non-nil lengthy recognition process is aborted
819simply by any key input."
820 :tag "Abort Recognition When Input Pending"
821 :type 'boolean
822 :group 'table)
823
824;;;###autoload
825(defcustom table-load-hook nil
826 "*List of functions to be called after the table is first loaded."
827 :type 'hook
828 :group 'table-hooks)
829
830;;;###autoload
831(defcustom table-point-entered-cell-hook nil
832 "*List of functions to be called after point entered a table cell."
833 :type 'hook
834 :group 'table-hooks)
835
836;;;###autoload
837(defcustom table-point-left-cell-hook nil
838 "*List of functions to be called after point left a table cell."
839 :type 'hook
840 :group 'table-hooks)
841
d6db9101
EZ
842(defcustom table-yank-handler '(nil nil t nil)
843 "*yank-handler for table.")
844
238240c9
RS
845(setplist 'table-disable-incompatibility-warning nil)
846
847(defvar table-disable-menu (null (and (locate-library "easymenu")
848 (require 'easymenu)
849 (fboundp 'easy-menu-add-item)))
850 "*When non-nil, use of menu by table package is disabled.
851It must be set before loading this package `table.el' for the first
852time.")
853
854\f
855;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
856;;;
857;;; Implementation:
858;;;
859
860;;; Internal variables and constants
861;;; No need of user configuration
862
863(defconst table-paragraph-start "[ \t\n\f]"
864 "*Regexp for beginning of a line that starts OR separates paragraphs.")
865(defconst table-cache-buffer-name " *table cell cache*"
866 "Cell cache buffer name.")
867(defvar table-cell-info-lu-coordinate nil
868 "Zero based coordinate of the cached cell's left upper corner.")
869(defvar table-cell-info-rb-coordinate nil
870 "Zero based coordinate of the cached cell's right bottom corner.")
871(defvar table-cell-info-width nil
872 "Number of characters per cached cell width.")
873(defvar table-cell-info-height nil
874 "Number of lines per cached cell height.")
875(defvar table-cell-info-justify nil
876 "Justification information of the cached cell.")
877(defvar table-cell-info-valign nil
878 "Vertical alignment information of the cached cell.")
879(defvar table-cell-self-insert-command-count 0
880 "Counter for undo control.")
881(defvar table-cell-map nil
882 "Keymap for table cell contents.")
883(defvar table-cell-global-map-alist nil
884 "Alist of copy of global maps that are substituted in `table-cell-map'.")
885(defvar table-global-menu-map nil
886 "Menu map created via `easy-menu-define'.")
887(defvar table-cell-menu-map nil
888 "Menu map created via `easy-menu-define'.")
889(defvar table-cell-buffer nil
890 "Buffer that contains the table cell.")
891(defvar table-cell-cache-point-coordinate nil
892 "Cache point coordinate based from the cell origin.")
893(defvar table-cell-cache-mark-coordinate nil
894 "Cache mark coordinate based from the cell origin.")
895(defvar table-cell-entered-state nil
896 "Records the state whether currently in a cell or nor.")
897(defvar table-update-timer nil
898 "Timer id for deferred cell update.")
899(defvar table-widen-timer nil
900 "Timer id for deferred cell update.")
901(defvar table-heighten-timer nil
902 "Timer id for deferred cell update.")
903(defvar table-inhibit-update nil
904 "Non-nil inhibits implicit cell and cache updates.
905It inhibits `table-with-cache-buffer' to update data in both direction, cell to cache and cache to cell.")
906(defvar table-inhibit-auto-fill-paragraph nil
907 "Non-nil inhibits auto fill paragraph when `table-with-cache-buffer' exits.
908This is always set to nil at the entry to `table-with-cache-buffer' before executing body forms.")
909(defvar table-mode-indicator nil
910 "For mode line indicator")
911(defvar table-fixed-mode-indicator nil
912 "For mode line indicator")
913(defconst table-source-languages '(html latex cals)
914 "Supported source languages.")
915(defvar table-source-info-plist nil
916 "General storage for temporary information used while generating source.")
917;;; These are not real minor-mode but placed in the minor-mode-alist
918;;; so that we can show the indicator on the mode line handy.
919(mapcar (lambda (indicator)
920 (make-variable-buffer-local (car indicator))
921 (unless (assq (car indicator) minor-mode-alist)
922 (setq minor-mode-alist
923 (cons indicator minor-mode-alist))))
924 '((table-mode-indicator " Table")
925 (table-fixed-mode-indicator " Fixed-Table")))
926;;; The following history containers not only keep the history of user
927;;; entries but also serve as the default value providers. When an
928;;; interactive command is invoked it offers a user the latest entry
929;;; of the history as a default selection. Therefore the values below
930;;; are the first default value when a command is invoked for the very
931;;; first time when there is no real history existing yet.
932(defvar table-cell-span-direction-history '("right"))
933(defvar table-cell-split-orientation-history '("horizontally"))
934(defvar table-cell-split-contents-to-history '("split"))
935(defvar table-insert-row-column-history '("row"))
936(defvar table-justify-history '("center"))
937(defvar table-columns-history '("3"))
938(defvar table-rows-history '("3"))
939(defvar table-cell-width-history '("5"))
940(defvar table-cell-height-history '("1"))
941(defvar table-source-caption-history '("Table"))
942(defvar table-sequence-string-history '("0"))
943(defvar table-sequence-count-history '("0"))
944(defvar table-sequence-increment-history '("1"))
945(defvar table-sequence-interval-history '("1"))
946(defvar table-sequence-justify-history '("left"))
947(defvar table-source-language-history '("html"))
948(defvar table-col-delim-regexp-history '(""))
949(defvar table-row-delim-regexp-history '(""))
950(defvar table-capture-justify-history '("left"))
951(defvar table-capture-min-cell-width-history '("5"))
952(defvar table-capture-columns-history '(""))
953(defvar table-target-history '("cell"))
954
955;;; Some entries in `table-cell-bindings' are duplicated in
956;;; `table-command-remap-alist'. There is a good reason for
957;;; this. Common key like return key may be taken by some other
958;;; function than normal `newline' function. Thus binding return key
959;;; directly for `*table--cell-newline' ensures that the correct enter
960;;; operation in a table cell. However
961;;; `table-command-remap-alist' has an additional role than
962;;; replacing commands. It is also used to construct a table command
963;;; list. This list is very important because it is used to check if
964;;; the previous command was one of them in this list or not. If the
965;;; previous command is found in the list the current command will not
966;;; refill the table cache. If the command were not listed fast
967;;; typing can cause unwanted cache refill.
968(defconst table-cell-bindings
969 '(([(control i)] . table-forward-cell)
970 ([(control I)] . table-backward-cell)
971 ([tab] . table-forward-cell)
972 ([(shift backtab)] . table-backward-cell) ; for HPUX console keyboard
973 ([(shift iso-lefttab)] . table-backward-cell) ; shift-tab on a microsoft natural keyboard and redhat linux
974 ([(shift tab)] . table-backward-cell)
975 ([return] . *table--cell-newline)
976 ([(control m)] . *table--cell-newline)
977 ([(control j)] . *table--cell-newline-and-indent)
978 ([mouse-3] . *table--present-cell-popup-menu)
979 ([(control ?>)] . table-widen-cell)
980 ([(control ?<)] . table-narrow-cell)
981 ([(control ?})] . table-heighten-cell)
982 ([(control ?{)] . table-shorten-cell)
983 ([(control ?-)] . table-split-cell-vertically)
984 ([(control ?|)] . table-split-cell-horizontally)
985 ([(control ?*)] . table-span-cell)
986 ([(control ?+)] . table-insert-row-column)
987 ([(control ?!)] . table-fixed-width-mode)
988 ([(control ?#)] . table-query-dimension)
989 ([(control ?^)] . table-generate-source)
990 ([(control ?:)] . table-justify)
991 )
992 "Bindings for table cell commands.")
993
e99add21 994(defvar table-command-remap-alist
238240c9
RS
995 '((self-insert-command . *table--cell-self-insert-command)
996 (completion-separator-self-insert-autofilling . *table--cell-self-insert-command)
997 (completion-separator-self-insert-command . *table--cell-self-insert-command)
998 (delete-char . *table--cell-delete-char)
999 (delete-backward-char . *table--cell-delete-backward-char)
1000 (backward-delete-char . *table--cell-delete-backward-char)
1001 (backward-delete-char-untabify . *table--cell-delete-backward-char)
1002 (newline . *table--cell-newline)
1003 (newline-and-indent . *table--cell-newline-and-indent)
1004 (open-line . *table--cell-open-line)
1005 (quoted-insert . *table--cell-quoted-insert)
1006 (describe-mode . *table--cell-describe-mode)
1007 (describe-bindings . *table--cell-describe-bindings)
1008 (dabbrev-expand . *table--cell-dabbrev-expand)
1009 (dabbrev-completion . *table--cell-dabbrev-completion))
1010 "List of cons cells consisting of (ORIGINAL-COMMAND . TABLE-VERSION-OF-THE-COMMAND).")
1011
e99add21 1012(defvar table-command-list nil
238240c9
RS
1013 "List of commands that override original commands.")
1014;; construct the real contents of the `table-command-list'
1015(let ((remap-alist table-command-remap-alist))
1016 (setq table-command-list nil)
1017 (while remap-alist
1018 (setq table-command-list (cons (cdar remap-alist) table-command-list))
1019 (setq remap-alist (cdr remap-alist))))
1020
1021(defconst table-global-menu
1022 '("Table"
1023 ("Insert"
1024 ["a Table..." table-insert
1025 :active (and (not buffer-read-only) (not (table--probe-cell)))
1026 :help "Insert a text based table at point"]
1027 ["Row" table-insert-row
951f97e6 1028 :active (table--row-column-insertion-point-p)
238240c9
RS
1029 :help "Insert row(s) of cells in table"]
1030 ["Column" table-insert-column
951f97e6 1031 :active (table--row-column-insertion-point-p 'column)
238240c9
RS
1032 :help "Insert column(s) of cells in table"])
1033 "----"
1034 ("Recognize"
1035 ["in Buffer" table-recognize
1036 :active t
1037 :help "Recognize all tables in the current buffer"]
1038 ["in Region" table-recognize-region
1039 :active (and mark-active (not (eq (mark t) (point))))
1040 :help "Recognize all tables in the current region"]
1041 ["a Table" table-recognize-table
1042 :active (table--probe-cell)
1043 :help "Recognize a table at point"]
1044 ["a Cell" table-recognize-cell
1045 :active (let ((cell (table--probe-cell)))
1046 (and cell (null (table--at-cell-p (car cell)))))
1047 :help "Recognize a cell at point"])
1048 ("Unrecognize"
1049 ["in Buffer" table-unrecognize
1050 :active t
1051 :help "Unrecognize all tables in the current buffer"]
1052 ["in Region" table-unrecognize-region
1053 :active (and mark-active (not (eq (mark t) (point))))
1054 :help "Unrecognize all tables in the current region"]
1055 ["a Table" table-unrecognize-table
1056 :active (table--probe-cell)
1057 :help "Unrecognize the current table"]
1058 ["a Cell" table-unrecognize-cell
1059 :active (let ((cell (table--probe-cell)))
1060 (and cell (table--at-cell-p (car cell))))
1061 :help "Unrecognize the current cell"])
1062 "----"
1063 ["Capture Region" table-capture
1064 :active (and (not buffer-read-only) mark-active (not (eq (mark t) (point))) (not (table--probe-cell)))
1065 :help "Capture text in the current region as a table"]
1066 ["Release" table-release
1067 :active (table--editable-cell-p)
1068 :help "Release the current table as plain text"]))
1069
1070(defconst table-cell-menu
1071 '("Table"
1072 ("Insert"
1073 ["Row" table-insert-row
951f97e6 1074 :active (table--row-column-insertion-point-p)
238240c9
RS
1075 :help "Insert row(s) of cells in table"]
1076 ["Column" table-insert-column
951f97e6 1077 :active (table--row-column-insertion-point-p 'column)
238240c9
RS
1078 :help "Insert column(s) of cells in table"])
1079 ("Delete"
1080 ["Row" table-delete-row
1081 :active (table--editable-cell-p)
1082 :help "Delete row(s) of cells in table"]
1083 ["Column" table-delete-column
1084 :active (table--editable-cell-p)
1085 :help "Delete column(s) of cells in table"])
1086 "----"
1087 ("Split a Cell"
1088 ["Horizontally" table-split-cell-horizontally
1089 :active (table--cell-can-split-horizontally-p)
1090 :help "Split the current cell horizontally at point"]
1091 ["Vertically" table-split-cell-vertically
1092 :active (table--cell-can-split-vertically-p)
1093 :help "Split the current cell vertical at point"])
1094 ("Span a Cell to"
1095 ["Right" (table-span-cell 'right)
1096 :active (table--cell-can-span-p 'right)
1097 :help "Span the current cell into the right cell"]
1098 ["Left" (table-span-cell 'left)
1099 :active (table--cell-can-span-p 'left)
1100 :help "Span the current cell into the left cell"]
1101 ["Above" (table-span-cell 'above)
1102 :active (table--cell-can-span-p 'above)
1103 :help "Span the current cell into the cell above"]
1104 ["Below" (table-span-cell 'below)
1105 :active (table--cell-can-span-p 'below)
1106 :help "Span the current cell into the cell below"])
1107 "----"
1108 ("Shrink Cells"
1109 ["Horizontally" table-narrow-cell
1110 :active (table--editable-cell-p)
1111 :help "Shrink the current cell horizontally"]
1112 ["Vertically" table-shorten-cell
1113 :active (table--editable-cell-p)
1114 :help "Shrink the current cell vertically"])
1115 ("Expand Cells"
1116 ["Horizontally" table-widen-cell
1117 :active (table--editable-cell-p)
1118 :help "Expand the current cell horizontally"]
1119 ["Vertically" table-heighten-cell
1120 :active (table--editable-cell-p)
1121 :help "Expand the current cell vertically"])
1122 "----"
1123 ("Justify"
1124 ("a Cell"
1125 ["Left" (table-justify-cell 'left)
1126 :active (table--editable-cell-p)
1127 :help "Left justify the contents of the current cell"]
1128 ["Center" (table-justify-cell 'center)
1129 :active (table--editable-cell-p)
1130 :help "Center justify the contents of the current cell"]
1131 ["Right" (table-justify-cell 'right)
1132 :active (table--editable-cell-p)
1133 :help "Right justify the contents of the current cell"]
1134 "----"
1135 ["Top" (table-justify-cell 'top)
1136 :active (table--editable-cell-p)
1137 :help "Top align the contents of the current cell"]
1138 ["Middle" (table-justify-cell 'middle)
1139 :active (table--editable-cell-p)
1140 :help "Middle align the contents of the current cell"]
1141 ["Bottom" (table-justify-cell 'bottom)
1142 :active (table--editable-cell-p)
1143 :help "Bottom align the contents of the current cell"]
1144 ["None" (table-justify-cell 'none)
1145 :active (table--editable-cell-p)
1146 :help "Remove vertical alignment from the current cell"])
1147 ("a Row"
1148 ["Left" (table-justify-row 'left)
1149 :active (table--editable-cell-p)
1150 :help "Left justify the contents of all cells in the current row"]
1151 ["Center" (table-justify-row 'center)
1152 :active (table--editable-cell-p)
1153 :help "Center justify the contents of all cells in the current row"]
1154 ["Right" (table-justify-row 'right)
1155 :active (table--editable-cell-p)
1156 :help "Right justify the contents of all cells in the current row"]
1157 "----"
1158 ["Top" (table-justify-row 'top)
1159 :active (table--editable-cell-p)
1160 :help "Top align the contents of all cells in the current row"]
1161 ["Middle" (table-justify-row 'middle)
1162 :active (table--editable-cell-p)
1163 :help "Middle align the contents of all cells in the current row"]
1164 ["Bottom" (table-justify-row 'bottom)
1165 :active (table--editable-cell-p)
1166 :help "Bottom align the contents of all cells in the current row"]
1167 ["None" (table-justify-cell 'none)
1168 :active (table--editable-cell-p)
1169 :help "Remove vertical alignment from all cells in the current row"])
1170 ("a Column"
1171 ["Left" (table-justify-column 'left)
1172 :active (table--editable-cell-p)
1173 :help "Left justify the contents of all cells in the current column"]
1174 ["Center" (table-justify-column 'center)
1175 :active (table--editable-cell-p)
1176 :help "Center justify the contents of all cells in the current column"]
1177 ["Right" (table-justify-column 'right)
1178 :active (table--editable-cell-p)
1179 :help "Right justify the contents of all cells in the current column"]
1180 "----"
1181 ["Top" (table-justify-column 'top)
1182 :active (table--editable-cell-p)
1183 :help "Top align the contents of all cells in the current column"]
1184 ["Middle" (table-justify-column 'middle)
1185 :active (table--editable-cell-p)
1186 :help "Middle align the contents of all cells in the current column"]
1187 ["Bottom" (table-justify-column 'bottom)
1188 :active (table--editable-cell-p)
1189 :help "Bottom align the contents of all cells in the current column"]
1190 ["None" (table-justify-cell 'none)
1191 :active (table--editable-cell-p)
1192 :help "Remove vertical alignment from all cells in the current column"])
1193 ("a Paragraph"
1194 ["Left" (table-justify-cell 'left t)
1195 :active (table--editable-cell-p)
1196 :help "Left justify the current paragraph"]
1197 ["Center" (table-justify-cell 'center t)
1198 :active (table--editable-cell-p)
1199 :help "Center justify the current paragraph"]
1200 ["Right" (table-justify-cell 'right t)
1201 :active (table--editable-cell-p)
1202 :help "Right justify the current paragraph"]))
1203 "----"
1204 ["Query Dimension" table-query-dimension
1205 :active (table--probe-cell)
1206 :help "Get the dimension of the current cell and the current table"]
1207 ["Generate Source" table-generate-source
1208 :active (table--probe-cell)
1209 :help "Generate source of the current table in the specified language"]
1210 ["Insert Sequence" table-insert-sequence
1211 :active (table--editable-cell-p)
1212 :help "Travel cells forward while inserting a specified sequence string in each cell"]
1213 ("Unrecognize"
1214 ["a Table" table-unrecognize-table
1215 :active (table--probe-cell)
1216 :help "Unrecognize the current table"]
1217 ["a Cell" table-unrecognize-cell
1218 :active (let ((cell (table--probe-cell)))
1219 (and cell (table--at-cell-p (car cell))))
1220 :help "Unrecognize the current cell"])
1221 ["Release" table-release
1222 :active (table--editable-cell-p)
1223 :help "Release the current table as plain text"]
1224 ("Configure Width to"
1225 ["Auto Expand Mode" (table-fixed-width-mode -1)
1226 :active t
1227 :style radio
1228 :selected (not table-fixed-width-mode)
1229 :help "A mode that allows automatic horizontal cell expansion"]
1230 ["Fixed Width Mode" (table-fixed-width-mode 1)
1231 :active t
1232 :style radio
1233 :selected table-fixed-width-mode
1234 :help "A mode that does not allow automatic horizontal cell expansion"])
1235 ("Navigate"
1236 ["Forward Cell" table-forward-cell
1237 :active (table--probe-cell)
1238 :help "Move point forward by cell(s)"]
1239 ["Backward Cell" table-backward-cell
1240 :active (table--probe-cell)
1241 :help "Move point backward by cell(s)"])
1242 ))
1243
1244;; XEmacs causes an error when encountering unknown keywords in the
1245;; menu definition. Specifically the :help keyword is new in Emacs 21
1246;; and causes error for the XEmacs function `check-menu-syntax'. IMHO
1247;; it is unwise to generate an error for unknown keywords because it
1248;; kills the nice backward compatible extensibility of keyword use.
1249;; Unknown keywords should be quietly ignore so that future extension
1250;; does not cause a problem in the old implementation. Sigh...
1251(when (featurep 'xemacs)
1252 (mapcar
1253 (defun table--tweak-menu-for-xemacs (menu)
1254 (cond
1255 ((listp menu)
1256 (mapcar 'table--tweak-menu-for-xemacs menu))
1257 ((vectorp menu)
1258 (let ((i 0) (len (length menu)))
1259 (while (< i len)
1260 ;; replace :help with something harmless.
1261 (if (eq (aref menu i) :help) (aset menu i :included))
1262 (setq i (1+ i)))))))
1263 (list table-global-menu table-cell-menu))
1264 (defvar mark-active t))
1265
1266;; register table menu under global tools menu
1267(unless table-disable-menu
1268 (easy-menu-define table-global-menu-map nil "Table global menu" table-global-menu)
1269 (if (featurep 'xemacs)
1270 (progn
1271 (easy-menu-add-item nil '("Tools") table-global-menu-map))
1272 (easy-menu-add-item (current-global-map) '("menu-bar" "tools") '("--"))
1273 (easy-menu-add-item (current-global-map) '("menu-bar" "tools") table-global-menu-map)))
1274
1275;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1276;;
1277;; Macros
1278;;
1279
1280(defmacro table-with-cache-buffer (&rest body)
1281 "Execute the forms in BODY with table cache buffer as the current buffer.
1282This macro simplifies the rest of the work greatly by condensing the
1283common idiom used in many of the cell manipulation functions. It does
1284not return any meaningful value.
1285
1286Save the current buffer and set the cache buffer as the current
1287buffer. Move the point to the cache buffer coordinate
1288`table-cell-cache-point-coordinate'. After BODY forms are executed,
1289the paragraph is filled as long as `table-inhibit-auto-fill-paragraph'
1290remains nil. BODY can set it to t when it does not want to fill the
1291paragraph. If necessary the cell width and height are extended as the
1292consequence of cell content modification by the BODY. Then the
1293current buffer is restored to the original one. The last cache point
1294coordinate is stored in `table-cell-cache-point-coordinate'. The
1295original buffer's point is moved to the location that corresponds to
1296the last cache point coordinate."
1297 (let ((height-expansion (make-symbol "height-expansion-var-symbol"))
1298 (width-expansion (make-symbol "width-expansion-var-symbol")))
1299 `(let (,height-expansion ,width-expansion)
1300 ;; make sure cache has valid data unless it is explicitly inhibited.
1301 (unless table-inhibit-update
1302 (table-recognize-cell))
1303 (with-current-buffer (get-buffer-create table-cache-buffer-name)
1304 ;; goto the cell coordinate based on `table-cell-cache-point-coordinate'.
1305 (set-mark (table--goto-coordinate table-cell-cache-mark-coordinate))
1306 (table--goto-coordinate table-cell-cache-point-coordinate)
1307 (table--untabify-line)
1308 ;; always reset before executing body forms because auto-fill behavior is the default.
1309 (setq table-inhibit-auto-fill-paragraph nil)
1310 ;; do the body
1311 ,@body
1312 ;; fill paragraph unless the body does not want to by setting `table-inhibit-auto-fill-paragraph'.
1313 (unless table-inhibit-auto-fill-paragraph
1314 (if (and table-cell-info-justify
1315 (not (eq table-cell-info-justify 'left)))
1316 (table--fill-region (point-min) (point-max))
1317 (table--fill-region
1318 (save-excursion (forward-paragraph -1) (point))
1319 (save-excursion (forward-paragraph 1) (point)))))
1320 ;; keep the updated cell coordinate.
1321 (setq table-cell-cache-point-coordinate (table--get-coordinate))
1322 ;; determine the cell width expansion.
1323 (setq ,width-expansion (table--measure-max-width))
1324 (if (<= ,width-expansion table-cell-info-width) nil
1325 (table--fill-region (point-min) (point-max) ,width-expansion)
1326 ;; keep the updated cell coordinate.
1327 (setq table-cell-cache-point-coordinate (table--get-coordinate)))
1328 (setq ,width-expansion (- ,width-expansion table-cell-info-width))
1329 ;; determine the cell height expansion.
1330 (if (looking-at "\\s *\\'") nil
1331 (goto-char (point-min))
1332 (if (re-search-forward "\\(\\s *\\)\\'" nil t)
1333 (goto-char (match-beginning 1))))
1334 (setq ,height-expansion (- (cdr (table--get-coordinate)) (1- table-cell-info-height))))
1335 ;; now back to the table buffer.
1336 ;; expand the cell width in the table buffer if necessary.
1337 (if (> ,width-expansion 0)
1338 (table-widen-cell ,width-expansion 'no-copy 'no-update))
1339 ;; expand the cell height in the table buffer if necessary.
1340 (if (> ,height-expansion 0)
1341 (table-heighten-cell ,height-expansion 'no-copy 'no-update))
1342 ;; do valign
1343 (with-current-buffer (get-buffer-create table-cache-buffer-name)
1344 (table--goto-coordinate table-cell-cache-point-coordinate)
1345 (setq table-cell-cache-point-coordinate (table--valign)))
1346 ;; move the point in the table buffer to the location that corresponds to
1347 ;; the location in the cell cache buffer
1348 (table--goto-coordinate (table--transcoord-cache-to-table table-cell-cache-point-coordinate))
1349 ;; set up the update timer unless it is explicitly inhibited.
1350 (unless table-inhibit-update
1351 (table--update-cell)))))
1352
1353;; for debugging the body form of the macro
1354(put 'table-with-cache-buffer 'edebug-form-spec '(body))
1355;; for neat presentation use the same indentation as `progn'
1356(put 'table-with-cache-buffer 'lisp-indent-function 0)
1357(if (or (featurep 'xemacs)
1358 (null (fboundp 'font-lock-add-keywords))) nil
1359 ;; color it as a keyword
1360 (font-lock-add-keywords
1361 'emacs-lisp-mode
1362 '("\\<table-with-cache-buffer\\>")))
1363
1364(defmacro table-put-source-info (prop value)
1365 "Register source generation information."
1366 `(put 'table-source-info-plist ,prop ,value))
1367
1368(defmacro table-get-source-info (prop)
1369 "Retrieve source generation information."
1370 `(get 'table-source-info-plist ,prop))
1371
1372;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1373;;
1374;; Modified commands for cell operation
1375;;
1376
1377;; Point Motion Only Group
1378(mapcar
1379 (lambda (command)
1380 (let ((func-symbol (intern (format "*table--cell-%s" command)))
1381 (doc-string (format "Table remapped function for `%s'." command)))
1382 (fset func-symbol
1383 `(lambda
1384 (&rest args)
1385 ,doc-string
1386 (interactive)
1387 (let ((table-inhibit-update t)
1388 (deactivate-mark nil))
1389 (table--finish-delayed-tasks)
1390 (table-recognize-cell 'force)
1391 (table-with-cache-buffer
1392 (call-interactively ',command)
1393 (setq table-inhibit-auto-fill-paragraph t)))))
1394 (setq table-command-remap-alist
1395 (cons (cons command func-symbol)
1396 table-command-remap-alist))))
1397 '(beginning-of-line
1398 end-of-line
1399 beginning-of-buffer
1400 end-of-buffer
1401 forward-word
1402 backward-word
7780d793
JB
1403 forward-sentence
1404 backward-sentence
238240c9
RS
1405 forward-paragraph
1406 backward-paragraph))
1407
1408;; Extraction Group
1409(mapcar
1410 (lambda (command)
1411 (let ((func-symbol (intern (format "*table--cell-%s" command)))
1412 (doc-string (format "Table remapped function for `%s'." command)))
1413 (fset func-symbol
1414 `(lambda
1415 (&rest args)
1416 ,doc-string
1417 (interactive)
1418 (table--finish-delayed-tasks)
1419 (table-recognize-cell 'force)
1420 (table-with-cache-buffer
1421 (table--remove-cell-properties (point-min) (point-max))
1422 (table--remove-eol-spaces (point-min) (point-max))
1423 (call-interactively ',command))
1424 (table--finish-delayed-tasks)))
1425 (setq table-command-remap-alist
1426 (cons (cons command func-symbol)
1427 table-command-remap-alist))))
1428 '(kill-region
7780d793 1429 kill-ring-save
238240c9
RS
1430 delete-region
1431 copy-region-as-kill
7780d793
JB
1432 kill-line
1433 kill-word
1434 backward-kill-word
1435 kill-sentence
1436 backward-kill-sentence
1437 kill-paragraph
1438 backward-kill-paragraph
1439 kill-sexp
1440 backward-kill-sexp))
238240c9
RS
1441
1442;; Pasting Group
1443(mapcar
1444 (lambda (command)
1445 (let ((func-symbol (intern (format "*table--cell-%s" command)))
1446 (doc-string (format "Table remapped function for `%s'." command)))
1447 (fset func-symbol
1448 `(lambda
1449 (&rest args)
1450 ,doc-string
1451 (interactive)
1452 (table--finish-delayed-tasks)
1453 (table-recognize-cell 'force)
1454 (table-with-cache-buffer
1455 (call-interactively ',command)
1456 (table--untabify (point-min) (point-max))
1457 (table--fill-region (point-min) (point-max))
1458 (setq table-inhibit-auto-fill-paragraph t))
1459 (table--finish-delayed-tasks)))
1460 (setq table-command-remap-alist
1461 (cons (cons command func-symbol)
1462 table-command-remap-alist))))
1463 '(yank
1464 clipboard-yank
1465 yank-clipboard-selection
1466 insert))
1467
1468;; Formatting Group
1469(mapcar
1470 (lambda (command)
1471 (let ((func-symbol (intern (format "*table--cell-%s" command)))
1472 (doc-string (format "Table remapped function for `%s'." command)))
1473 (fset func-symbol
1474 `(lambda
1475 (&rest args)
1476 ,doc-string
1477 (interactive)
1478 (table--finish-delayed-tasks)
1479 (table-recognize-cell 'force)
1480 (table-with-cache-buffer
1481 (let ((fill-column table-cell-info-width))
1482 (call-interactively ',command))
1483 (setq table-inhibit-auto-fill-paragraph t))
1484 (table--finish-delayed-tasks)))
1485 (setq table-command-remap-alist
1486 (cons (cons command func-symbol)
1487 table-command-remap-alist))))
1488 '(center-line
1489 conter-region
1490 center-paragraph
1491 fill-paragraph))
1492
1493;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1494;;
1495;; Commands
1496;;
1497
1498;;;###autoload
1499(defun table-insert (columns rows &optional cell-width cell-height)
1500 "Insert an editable text table.
1501Insert a table of specified number of COLUMNS and ROWS. Optional
1502parameter CELL-WIDTH and CELL-HEIGHT can specify the size of each
1503cell. The cell size is uniform across the table if the specified size
1504is a number. They can be a list of numbers to specify different size
1505for each cell. When called interactively, the list of number is
1506entered by simply listing all the numbers with space characters
1507delimiting them.
1508
1509Examples:
1510
1511\\[table-insert] inserts a table at the current point location.
1512
1513Suppose we have the following situation where `-!-' indicates the
1514location of point.
1515
1516 -!-
1517
1518Type \\[table-insert] and hit ENTER key. As it asks table
1519specification, provide 3 for number of columns, 1 for number of rows,
15205 for cell width and 1 for cell height. Now you shall see the next
1521table and the point is automatically moved to the beginning of the
1522first cell.
1523
1524 +-----+-----+-----+
1525 |-!- | | |
1526 +-----+-----+-----+
1527
1528Inside a table cell, there are special key bindings. \\<table-cell-map>
1529
1530M-9 \\[table-widen-cell] (or \\[universal-argument] 9 \\[table-widen-cell]) widens the first cell by 9 character
1531width, which results as
1532
1533 +--------------+-----+-----+
1534 |-!- | | |
1535 +--------------+-----+-----+
1536
1537Type TAB \\[table-widen-cell] then type TAB M-2 M-7 \\[table-widen-cell] (or \\[universal-argument] 2 7 \\[table-widen-cell]). Typing
1538TAB moves the point forward by a cell. The result now looks like this:
1539
1540 +--------------+------+--------------------------------+
1541 | | |-!- |
1542 +--------------+------+--------------------------------+
1543
1544If you knew each width of the columns prior to the table creation,
1545what you could have done better was to have had given the complete
1546width information to `table-insert'.
1547
1548Cell width(s): 14 6 32
1549
db95369b 1550instead of
238240c9
RS
1551
1552Cell width(s): 5
1553
1554This would have eliminated the previously mentioned width adjustment
1555work all together.
1556
1557If the point is in the last cell type S-TAB S-TAB to move it to the
1558first cell. Now type \\[table-heighten-cell] which heighten the row by a line.
1559
1560 +--------------+------+--------------------------------+
1561 |-!- | | |
1562 | | | |
1563 +--------------+------+--------------------------------+
1564
1565Type \\[table-insert-row-column] and tell it to insert a row.
1566
1567 +--------------+------+--------------------------------+
1568 |-!- | | |
1569 | | | |
1570 +--------------+------+--------------------------------+
1571 | | | |
1572 | | | |
1573 +--------------+------+--------------------------------+
1574
1575Move the point under the table as shown below.
1576
1577 +--------------+------+--------------------------------+
1578 | | | |
1579 | | | |
1580 +--------------+------+--------------------------------+
1581 | | | |
1582 | | | |
1583 +--------------+------+--------------------------------+
1584 -!-
1585
1586Type M-x table-insert-row instead of \\[table-insert-row-column]. \\[table-insert-row-column] does not work
1587when the point is outside of the table. This insertion at
1588outside of the table effectively appends a row at the end.
1589
1590 +--------------+------+--------------------------------+
1591 | | | |
1592 | | | |
1593 +--------------+------+--------------------------------+
1594 | | | |
1595 | | | |
1596 +--------------+------+--------------------------------+
1597 |-!- | | |
1598 | | | |
1599 +--------------+------+--------------------------------+
1600
1601Text editing inside the table cell produces reasonably expected
1602results.
1603
1604 +--------------+------+--------------------------------+
1605 | | | |
1606 | | | |
1607 +--------------+------+--------------------------------+
1608 | | |Text editing inside the table |
1609 | | |cell produces reasonably |
1610 | | |expected results.-!- |
1611 +--------------+------+--------------------------------+
1612 | | | |
1613 | | | |
1614 +--------------+------+--------------------------------+
1615
1616Inside a table cell has a special keymap.
1617
1618\\{table-cell-map}
1619"
1620 (interactive
1621 (progn
1622 (barf-if-buffer-read-only)
1623 (if (table--probe-cell)
1624 (error "Can't insert a table inside a table"))
1625 (mapcar (function table--read-from-minibuffer)
1626 '(("Number of columns" . table-columns-history)
1627 ("Number of rows" . table-rows-history)
1628 ("Cell width(s)" . table-cell-width-history)
1629 ("Cell height(s)" . table-cell-height-history)))))
1630 (table--make-cell-map)
1631 ;; reform the arguments.
1632 (if (null cell-width) (setq cell-width (car table-cell-width-history)))
1633 (if (null cell-height) (setq cell-height (car table-cell-height-history)))
1634 (if (stringp columns) (setq columns (string-to-number columns)))
1635 (if (stringp rows) (setq rows (string-to-number rows)))
1636 (if (stringp cell-width) (setq cell-width (table--string-to-number-list cell-width)))
1637 (if (stringp cell-height) (setq cell-height (table--string-to-number-list cell-height)))
1638 (if (numberp cell-width) (setq cell-width (cons cell-width nil)))
1639 (if (numberp cell-height) (setq cell-height (cons cell-height nil)))
1640 ;; test validity of the arguments.
1641 (mapcar (lambda (arg)
1642 (let* ((value (symbol-value arg))
1643 (error-handler
1644 (function (lambda ()
1645 (error "%s must be a positive integer%s" arg
1646 (if (listp value) " or a list of positive integers" ""))))))
1647 (if (null value) (funcall error-handler))
1648 (mapcar (function (lambda (arg1)
1649 (if (or (not (integerp arg1))
1650 (< arg1 1))
1651 (funcall error-handler))))
1652 (if (listp value) value
1653 (cons value nil)))))
1654 '(columns rows cell-width cell-height))
1655 (let ((orig-coord (table--get-coordinate))
1656 (coord (table--get-coordinate))
1657 r i cw ch cell-str border-str)
1658 ;; prefabricate the building blocks border-str and cell-str.
1659 (with-temp-buffer
1660 ;; construct border-str
1661 (insert table-cell-intersection-char)
1662 (setq cw cell-width)
1663 (setq i 0)
1664 (while (< i columns)
e99add21 1665 (insert (make-string (car cw) (string-to-char table-cell-horizontal-chars)) table-cell-intersection-char)
238240c9
RS
1666 (if (cdr cw) (setq cw (cdr cw)))
1667 (setq i (1+ i)))
1668 (setq border-str (buffer-substring (point-min) (point-max)))
1669 ;; construct cell-str
1670 (erase-buffer)
1671 (insert table-cell-vertical-char)
1672 (setq cw cell-width)
1673 (setq i 0)
1674 (while (< i columns)
1675 (let ((beg (point)))
1676 (insert (make-string (car cw) ?\ ))
1677 (insert table-cell-vertical-char)
1678 (table--put-cell-line-property beg (1- (point))))
1679 (if (cdr cw) (setq cw (cdr cw)))
1680 (setq i (1+ i)))
1681 (setq cell-str (buffer-substring (point-min) (point-max))))
1682 ;; if the construction site has an empty border push that border down.
1683 (save-excursion
1684 (beginning-of-line)
1685 (if (looking-at "\\s *$")
1686 (progn
1687 (setq border-str (concat border-str "\n"))
1688 (setq cell-str (concat cell-str "\n")))))
1689 ;; now build the table using the prefabricated building blocks
1690 (setq r 0)
1691 (setq ch cell-height)
1692 (while (< r rows)
1693 (if (> r 0) nil
1694 (table--goto-coordinate coord) (setcdr coord (1+ (cdr coord)))
1695 (table--untabify-line (point))
1696 (insert border-str))
1697 (setq i 0)
1698 (while (< i (car ch))
1699 (table--goto-coordinate coord) (setcdr coord (1+ (cdr coord)))
1700 (table--untabify-line (point))
1701 (insert cell-str)
1702 (setq i (1+ i)))
1703 (table--goto-coordinate coord) (setcdr coord (1+ (cdr coord)))
1704 (table--untabify-line (point))
1705 (insert border-str)
1706 (if (cdr ch) (setq ch (cdr ch)))
1707 (setq r (1+ r)))
1708 ;; stand by at the first cell
1709 (table--goto-coordinate (table--offset-coordinate orig-coord '(1 . 1)))
1710 (table-recognize-cell 'force)))
1711
1712;;;###autoload
1713(defun table-insert-row (n)
1714 "Insert N table row(s).
1715When point is in a table the newly inserted row(s) are placed above
1716the current row. When point is outside of the table it must be below
1717the table within the table width range, then the newly created row(s)
1718are appended at the bottom of the table."
1719 (interactive "*p")
1720 (if (< n 0) (setq n 1))
1721 (let* ((current-coordinate (table--get-coordinate))
1722 (coord-list (table--cell-list-to-coord-list (table--horizontal-cell-list t nil 'top)))
1723 (append-row (if coord-list nil (setq coord-list (table--find-row-column))))
1724 (cell-height (cdr (table--min-coord-list coord-list)))
1725 (left-list nil)
1726 (this-list coord-list)
1727 (right-list (cdr coord-list))
1728 (bottom-border-y (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))
1729 (vertical-str (string table-cell-vertical-char))
1730 (vertical-str-with-properties (let ((str (string table-cell-vertical-char)))
1731 (table--put-cell-keymap-property 0 (length str) str)
1732 (table--put-cell-rear-nonsticky 0 (length str) str) str))
1733 (first-time t))
1734 ;; create the space below for the table to grow
1735 (table--create-growing-space-below (* n (+ 1 cell-height)) coord-list bottom-border-y)
1736 ;; vertically expand each cell from left to right
1737 (while this-list
1738 (let* ((left (prog1 (car left-list) (setq left-list (if left-list (cdr left-list) coord-list))))
1739 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
1740 (right (prog1 (car right-list) (setq right-list (cdr right-list))))
1741 (exclude-left (and left (< (cdar left) (cdar this))))
1742 (exclude-right (and right (<= (cdar right) (cdar this))))
1743 (beg (table--goto-coordinate
1744 (cons (if exclude-left (caar this) (1- (caar this)))
1745 (cdar this))))
1746 (end (table--goto-coordinate
1747 (cons (if exclude-right (cadr this) (1+ (cadr this)))
1748 bottom-border-y)))
1749 (rect (if append-row nil (extract-rectangle beg end))))
1750 ;; prepend blank cell lines to the extracted rectangle
1751 (let ((i n))
1752 (while (> i 0)
1753 (setq rect (cons
1754 (concat (if exclude-left "" (char-to-string table-cell-intersection-char))
e99add21 1755 (make-string (- (cadr this) (caar this)) (string-to-char table-cell-horizontal-chars))
238240c9
RS
1756 (if exclude-right "" (char-to-string table-cell-intersection-char)))
1757 rect))
1758 (let ((j cell-height))
1759 (while (> j 0)
1760 (setq rect (cons
1761 (concat (if exclude-left ""
1762 (if first-time vertical-str vertical-str-with-properties))
1763 (table--cell-blank-str (- (cadr this) (caar this)))
1764 (if exclude-right "" vertical-str-with-properties))
1765 rect))
1766 (setq j (1- j))))
1767 (setq i (1- i))))
1768 (setq first-time nil)
1769 (if append-row
1770 (table--goto-coordinate (cons (if exclude-left (caar this) (1- (caar this)))
1771 (1+ bottom-border-y)))
1772 (delete-rectangle beg end)
1773 (goto-char beg))
1774 (table--insert-rectangle rect)))
1775 ;; fix up the intersections
1776 (setq this-list (if append-row nil coord-list))
1777 (while this-list
1778 (let ((this (prog1 (car this-list) (setq this-list (cdr this-list))))
1779 (i 0))
1780 (while (< i n)
1781 (let ((y (1- (* i (+ 1 cell-height)))))
1782 (table--goto-coordinate (table--offset-coordinate (car this) (cons -1 y)))
1783 (delete-char 1) (insert table-cell-intersection-char)
1784 (table--goto-coordinate (table--offset-coordinate (cons (cadr this) (cdar this)) (cons 0 y)))
1785 (delete-char 1) (insert table-cell-intersection-char)
1786 (setq i (1+ i))))))
1787 ;; move the point to the beginning of the first newly inserted cell.
1788 (if (table--goto-coordinate
1789 (if append-row (cons (car (caar coord-list)) (1+ bottom-border-y))
1790 (caar coord-list))) nil
1791 (table--goto-coordinate current-coordinate))
1792 ;; re-recognize the current cell's new dimension
1793 (table-recognize-cell 'force)))
1794
1795;;;###autoload
1796(defun table-insert-column (n)
1797 "Insert N table column(s).
1798When point is in a table the newly inserted column(s) are placed left
1799of the current column. When point is outside of the table it must be
1800right side of the table within the table height range, then the newly
1801created column(s) are appended at the right of the table."
1802 (interactive "*p")
1803 (if (< n 0) (setq n 1))
1804 (let* ((current-coordinate (table--get-coordinate))
1805 (coord-list (table--cell-list-to-coord-list (table--vertical-cell-list t nil 'left)))
1806 (append-column (if coord-list nil (setq coord-list (table--find-row-column 'column))))
1807 (cell-width (car (table--min-coord-list coord-list)))
e99add21 1808 (border-str (table--multiply-string (concat (make-string cell-width (string-to-char table-cell-horizontal-chars))
238240c9
RS
1809 (char-to-string table-cell-intersection-char)) n))
1810 (cell-str (table--multiply-string (concat (table--cell-blank-str cell-width)
1811 (let ((str (string table-cell-vertical-char)))
1812 (table--put-cell-keymap-property 0 (length str) str)
1813 (table--put-cell-rear-nonsticky 0 (length str) str) str)) n))
1814 (columns-to-extend (* n (+ 1 cell-width)))
1815 (above-list nil)
1816 (this-list coord-list)
1817 (below-list (cdr coord-list))
1818 (right-border-x (car (table--get-coordinate (cdr (table--horizontal-cell-list nil t))))))
1819 ;; push back the affected area above and below this table
1820 (table--horizontally-shift-above-and-below columns-to-extend coord-list)
1821 ;; process each cell vertically from top to bottom
1822 (while this-list
1823 (let* ((above (prog1 (car above-list) (setq above-list (if above-list (cdr above-list) coord-list))))
1824 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
1825 (below (prog1 (car below-list) (setq below-list (cdr below-list))))
1826 (exclude-above (and above (<= (caar above) (caar this))))
1827 (exclude-below (and below (< (caar below) (caar this))))
1828 (beg-coord (cons (if append-column (1+ right-border-x) (caar this))
1829 (if exclude-above (cdar this) (1- (cdar this)))))
1830 (end-coord (cons (1+ right-border-x)
1831 (if exclude-below (cddr this) (1+ (cddr this)))))
1832 rect)
1833 ;; untabify the area right of the bar that is about to be inserted
1834 (let ((coord (table--copy-coordinate beg-coord))
1835 (i 0)
1836 (len (length rect)))
1837 (while (< i len)
1838 (if (table--goto-coordinate coord 'no-extension)
1839 (table--untabify-line (point)))
1840 (setcdr coord (1+ (cdr coord)))
1841 (setq i (1+ i))))
1842 ;; extract and delete the rectangle area including the current
1843 ;; cell and to the right border of the table.
1844 (setq rect (extract-rectangle (table--goto-coordinate beg-coord)
1845 (table--goto-coordinate end-coord)))
1846 (delete-rectangle (table--goto-coordinate beg-coord)
1847 (table--goto-coordinate end-coord))
1848 ;; prepend the empty column string at the beginning of each
1849 ;; rectangle string extracted before.
1850 (let ((rect-str rect)
1851 (first t))
1852 (while rect-str
1853 (if (and first (null exclude-above))
1854 (setcar rect-str (concat border-str (car rect-str)))
1855 (if (and (null (cdr rect-str)) (null exclude-below))
1856 (setcar rect-str (concat border-str (car rect-str)))
1857 (setcar rect-str (concat cell-str (car rect-str)))))
1858 (setq first nil)
1859 (setq rect-str (cdr rect-str))))
1860 ;; insert the extended rectangle
1861 (table--goto-coordinate beg-coord)
1862 (table--insert-rectangle rect)))
1863 ;; fix up the intersections
1864 (setq this-list (if append-column nil coord-list))
1865 (while this-list
1866 (let ((this (prog1 (car this-list) (setq this-list (cdr this-list))))
1867 (i 0))
1868 (while (< i n)
1869 (let ((x (1- (* (1+ i) (+ 1 cell-width)))))
1870 (table--goto-coordinate (table--offset-coordinate (car this) (cons x -1)))
1871 (delete-char 1) (insert table-cell-intersection-char)
1872 (table--goto-coordinate (table--offset-coordinate (cons (caar this) (cddr this)) (cons x 1)))
1873 (delete-char 1) (insert table-cell-intersection-char)
1874 (setq i (1+ i))))))
1875 ;; move the point to the beginning of the first newly inserted cell.
1876 (if (table--goto-coordinate
1877 (if append-column
1878 (cons (1+ right-border-x)
1879 (cdar (car coord-list)))
1880 (caar coord-list))) nil
1881 (table--goto-coordinate current-coordinate))
1882 ;; re-recognize the current cell's new dimension
1883 (table-recognize-cell 'force)))
1884
1885;;;###autoload
1886(defun table-insert-row-column (row-column n)
1887 "Insert row(s) or column(s).
1888See `table-insert-row' and `table-insert-column'."
1889 (interactive
1890 (let ((n (prefix-numeric-value current-prefix-arg)))
1891 (if (< n 0) (setq n 1))
1892 (list (intern (let ((completion-ignore-case t)
1893 (default (car table-insert-row-column-history)))
1894 (downcase (completing-read
1895 (format "Insert %s row%s/column%s (default %s): "
1896 (if (> n 1) (format "%d" n) "a")
1897 (if (> n 1) "s" "")
1898 (if (> n 1) "s" "")
1899 default)
1900 '(("row") ("column"))
1901 nil t nil 'table-insert-row-column-history default))))
1902 n)))
1903 (cond ((eq row-column 'row)
1904 (table-insert-row n))
1905 ((eq row-column 'column)
1906 (table-insert-column n))))
1907
1908;;;###autoload
1909(defun table-recognize (&optional arg)
1910 "Recognize all tables within the current buffer and activate them.
1911Scans the entire buffer and recognizes valid table cells. If the
1912optional numeric prefix argument ARG is negative the tables in the
1913buffer become inactive, meaning the tables become plain text and loses
1914all the table specific features."
1915 (interactive "P")
1916 (setq arg (prefix-numeric-value arg))
1917 (let* ((inhibit-read-only t))
1918 (table-recognize-region (point-min) (point-max) -1)
1919 (if (>= arg 0)
1920 (save-excursion
1921 (goto-char (point-min))
e99add21
JB
1922 (let* ((border (format "[%s%c%c]"
1923 table-cell-horizontal-chars
238240c9
RS
1924 table-cell-vertical-char
1925 table-cell-intersection-char))
1926 (border3 (concat border border border))
e99add21
JB
1927 (non-border (format "^[^%s%c%c]*$"
1928 table-cell-horizontal-chars
238240c9
RS
1929 table-cell-vertical-char
1930 table-cell-intersection-char)))
1931 ;; `table-recognize-region' is an expensive function so minimize
1932 ;; the search area. A minimum table at least consists of three consecutive
1933 ;; table border characters to begin with such as
1934 ;; +-+
1935 ;; |A|
1936 ;; +-+
1937 ;; and any tables end with a line containing no table border characters
1938 ;; or the end of buffer.
1939 (while (and (re-search-forward border3 (point-max) t)
1940 (not (and (input-pending-p)
1941 table-abort-recognition-when-input-pending)))
1942 (message "Recognizing tables...(%d%%)" (/ (* 100 (match-beginning 0)) (- (point-max) (point-min))))
1943 (let ((beg (match-beginning 0))
1944 end)
1945 (if (re-search-forward non-border (point-max) t)
1946 (setq end (match-beginning 0))
1947 (setq end (goto-char (point-max))))
1948 (table-recognize-region beg end arg)))
1949 (message "Recognizing tables...done"))))))
1950
1951;;;###autoload
1952(defun table-unrecognize ()
1953 (interactive)
1954 (table-recognize -1))
1955
1956;;;###autoload
1957(defun table-recognize-region (beg end &optional arg)
1958 "Recognize all tables within region.
1959BEG and END specify the region to work on. If the optional numeric
1960prefix argument ARG is negative the tables in the region become
1961inactive, meaning the tables become plain text and lose all the table
1962specific features."
1963 (interactive "r\nP")
1964 (setq arg (prefix-numeric-value arg))
1965 (let ((inhibit-read-only t)
1966 (modified-flag (buffer-modified-p)))
1967 (if (< arg 0)
1968 (table--remove-cell-properties beg end)
1969 (save-excursion
1970 (goto-char beg)
e99add21
JB
1971 (let* ((border (format "[%s%c%c]"
1972 table-cell-horizontal-chars
238240c9
RS
1973 table-cell-vertical-char
1974 table-cell-intersection-char))
e99add21
JB
1975 (non-border (format "[^%s%c%c]"
1976 table-cell-horizontal-chars
238240c9
RS
1977 table-cell-vertical-char
1978 table-cell-intersection-char))
1979 (inhibit-read-only t))
1980 (unwind-protect
1981 (progn
1982 (remove-text-properties beg end '(table-cell nil))
1983 (while (and (< (point) end)
1984 (not (and (input-pending-p)
1985 table-abort-recognition-when-input-pending)))
1986 (cond
1987 ((looking-at "\n")
1988 (forward-char 1))
1989 ((looking-at border)
1990 (if (re-search-forward non-border end t)
1991 (goto-char (match-beginning 0))
1992 (goto-char end)))
1993 ((table--at-cell-p (point))
1994 (goto-char (next-single-property-change (point) 'table-cell nil end)))
1995 (t
1996 (let ((cell (table-recognize-cell 'force 'no-copy)))
1997 (if (and cell table-detect-cell-alignment)
1998 (table--detect-cell-alignment cell)))
1999 (unless (re-search-forward border end t)
2000 (goto-char end))))))))))
2001 (set-buffer-modified-p modified-flag)))
2002
2003;;;###autoload
2004(defun table-unrecognize-region (beg end)
2005 (interactive "r")
2006 (table-recognize-region beg end -1))
2007
2008;;;###autoload
2009(defun table-recognize-table (&optional arg)
2010 "Recognize a table at point.
2011If the optional numeric prefix argument ARG is negative the table
2012becomes inactive, meaning the table becomes plain text and loses all
2013the table specific features."
2014 (interactive "P")
2015 (setq arg (prefix-numeric-value arg))
2016 (let ((unrecognize (< arg 0))
2017 (origin-cell (table--probe-cell))
2018 (inhibit-read-only t))
2019 (if origin-cell
2020 (save-excursion
2021 (while
2022 (progn
2023 (table-forward-cell 1 nil unrecognize)
2024 (let ((cell (table--probe-cell)))
2025 (if (and cell table-detect-cell-alignment)
2026 (table--detect-cell-alignment cell))
2027 (and cell (not (equal cell origin-cell))))))))))
2028
2029;;;###autoload
2030(defun table-unrecognize-table ()
2031 (interactive)
2032 (table-recognize-table -1))
2033
2034;;;###autoload
2035(defun table-recognize-cell (&optional force no-copy arg)
2036 "Recognize a table cell that contains current point.
2037Probe the cell dimension and prepare the cell information. The
2038optional two arguments FORCE and NO-COPY are for internal use only and
2039must not be specified. When the optional numeric prefix argument ARG
2040is negative the cell becomes inactive, meaning that the cell becomes
2041plain text and loses all the table specific features."
2042 (interactive "i\ni\np")
2043 (table--make-cell-map)
2044 (if (or force (not (memq (table--get-last-command) table-command-list)))
2045 (let* ((cell (table--probe-cell (interactive-p)))
2046 (cache-buffer (get-buffer-create table-cache-buffer-name))
2047 (modified-flag (buffer-modified-p))
2048 (inhibit-read-only t))
2049 (unwind-protect
2050 (unless (null cell)
2051 ;; initialize the cell info variables
2052 (let ((lu-coordinate (table--get-coordinate (car cell)))
2053 (rb-coordinate (table--get-coordinate (cdr cell))))
2054 ;; update the previous cell if this cell is different from the previous one.
2055 ;; care only lu but ignore rb since size change does not matter.
2056 (unless (equal table-cell-info-lu-coordinate lu-coordinate)
2057 (table--finish-delayed-tasks))
2058 (setq table-cell-info-lu-coordinate lu-coordinate)
2059 (setq table-cell-info-rb-coordinate rb-coordinate)
2060 (setq table-cell-info-width (- (car table-cell-info-rb-coordinate)
2061 (car table-cell-info-lu-coordinate)))
2062 (setq table-cell-info-height (+ (- (cdr table-cell-info-rb-coordinate)
2063 (cdr table-cell-info-lu-coordinate)) 1))
2064 (setq table-cell-info-justify (table--get-cell-justify-property cell))
2065 (setq table-cell-info-valign (table--get-cell-valign-property cell)))
2066 ;; set/remove table cell properties
2067 (if (< (prefix-numeric-value arg) 0)
2068 (let ((coord (table--get-coordinate (car cell)))
2069 (n table-cell-info-height))
2070 (save-excursion
2071 (while (> n 0)
2072 (table--remove-cell-properties
2073 (table--goto-coordinate coord)
2074 (table--goto-coordinate (cons (+ (car coord) table-cell-info-width 1) (cdr coord))))
2075 (setq n (1- n))
2076 (setcdr coord (1+ (cdr coord))))))
2077 (table--put-cell-property cell))
2078 ;; copy the cell contents to the cache buffer
2079 ;; only if no-copy is nil and timers are not set
2080 (unless no-copy
2081 (setq table-cell-cache-point-coordinate (table--transcoord-table-to-cache))
2082 (setq table-cell-cache-mark-coordinate (table--transcoord-table-to-cache
2083 (table--get-coordinate (marker-position (mark-marker)))))
2084 (setq table-cell-buffer (current-buffer))
2085 (let ((rectangle (extract-rectangle (car cell)
2086 (cdr cell))))
2087 (save-current-buffer
2088 (set-buffer cache-buffer)
2089 (erase-buffer)
2090 (table--insert-rectangle rectangle)))))
2091 (set-buffer-modified-p modified-flag))
2092 (if (featurep 'xemacs)
2093 (table--warn-incompatibility))
2094 cell)))
2095
2096;;;###autoload
2097(defun table-unrecognize-cell ()
2098 (interactive)
2099 (table-recognize-cell nil nil -1))
2100
2101;;;###autoload
2102(defun table-heighten-cell (n &optional no-copy no-update)
2103 "Heighten the current cell by N lines by expanding the cell vertically.
2104Heightening is done by adding blank lines at the bottom of the current
2105cell. Other cells aligned horizontally with the current one are also
2106heightened in order to keep the rectangular table structure. The
2107optional argument NO-COPY is internal use only and must not be
2108specified."
2109 (interactive "*p")
2110 (if (< n 0) (setq n 1))
2111 (let* ((coord-list (table--cell-list-to-coord-list (table--horizontal-cell-list t)))
2112 (left-list nil)
2113 (this-list coord-list)
2114 (right-list (cdr coord-list))
2115 (bottom-border-y (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))
2116 (vertical-str (string table-cell-vertical-char))
2117 (vertical-str-with-properties (string table-cell-vertical-char))
2118 (first-time t)
2119 (current-coordinate (table--get-coordinate)))
2120 ;; prepare the right vertical string with appropriate properties put
2121 (table--put-cell-keymap-property 0 (length vertical-str-with-properties) vertical-str-with-properties)
2122 ;; create the space below for the table to grow
2123 (table--create-growing-space-below n coord-list bottom-border-y)
2124 ;; vertically expand each cell from left to right
2125 (while this-list
2126 (let* ((left (prog1 (car left-list) (setq left-list (if left-list (cdr left-list) coord-list))))
2127 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
2128 (right (prog1 (car right-list) (setq right-list (cdr right-list))))
2129 (exclude-left (and left (< (cddr left) (cddr this))))
2130 (exclude-right (and right (<= (cddr right) (cddr this))))
2131 (beg (table--goto-coordinate
2132 (cons (if exclude-left (caar this) (1- (caar this)))
2133 (1+ (cddr this)))))
2134 (end (table--goto-coordinate
2135 (cons (if exclude-right (cadr this) (1+ (cadr this)))
2136 bottom-border-y)))
2137 (rect (extract-rectangle beg end)))
2138 ;; prepend blank cell lines to the extracted rectangle
2139 (let ((i n))
2140 (while (> i 0)
2141 (setq rect (cons
2142 (concat (if exclude-left ""
2143 (if first-time vertical-str vertical-str-with-properties))
2144 (table--cell-blank-str (- (cadr this) (caar this)))
2145 (if exclude-right "" vertical-str-with-properties))
2146 rect))
2147 (setq i (1- i))))
2148 (setq first-time nil)
2149 (delete-rectangle beg end)
2150 (goto-char beg)
2151 (table--insert-rectangle rect)))
2152 (table--goto-coordinate current-coordinate)
2153 ;; re-recognize the current cell's new dimension
2154 (table-recognize-cell 'force no-copy)
2155 (unless no-update
2156 (table--update-cell-heightened))))
2157
2158;;;###autoload
2159(defun table-shorten-cell (n)
2160 "Shorten the current cell by N lines by shrinking the cell vertically.
2161Shortening is done by removing blank lines from the bottom of the cell
2162and possibly from the top of the cell as well. Therefor, the cell
2163must have some bottom/top blank lines to be shorten effectively. This
2164is applicable to all the cells aligned horizontally with the current
2165one because they are also shortened in order to keep the rectangular
2166table structure."
2167 (interactive "*p")
2168 (if (< n 0) (setq n 1))
2169 (table--finish-delayed-tasks)
2170 (let* ((table-inhibit-update t)
2171 (coord-list (table--cell-list-to-coord-list (table--horizontal-cell-list t)))
2172 (left-list nil)
2173 (this-list coord-list)
2174 (right-list (cdr coord-list))
2175 (bottom-budget-list nil)
2176 (bottom-border-y (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))
2177 (current-coordinate (table--get-coordinate))
2178 (current-cell-coordinate (table--cell-to-coord (table--probe-cell)))
2179 (blank-line-regexp "\\s *$"))
2180 (message "Shortening...");; this operation may be lengthy
2181 ;; for each cell calculate the maximum number of blank lines we can delete
2182 ;; and adjust the argument n. n is adjusted so that the total number of
2183 ;; blank lines from top and bottom of a cell do not exceed n, all cell has
2184 ;; at least one line height after blank line deletion.
2185 (while this-list
2186 (let ((this (prog1 (car this-list) (setq this-list (cdr this-list)))))
2187 (table--goto-coordinate (car this))
2188 (table-recognize-cell 'force)
2189 (table-with-cache-buffer
2190 (catch 'end-count
2191 (let ((blank-line-count 0))
2192 (table--goto-coordinate (cons 0 (1- table-cell-info-height)))
2193 ;; count bottom
2194 (while (and (looking-at blank-line-regexp)
2195 (setq blank-line-count (1+ blank-line-count))
2196 ;; need to leave at least one blank line
2197 (if (> blank-line-count n) (throw 'end-count nil) t)
2198 (if (zerop (forward-line -1)) t
2199 (setq n (if (zerop blank-line-count) 0
2200 (1- blank-line-count)))
2201 (throw 'end-count nil))))
2202 (table--goto-coordinate (cons 0 0))
2203 ;; count top
2204 (while (and (looking-at blank-line-regexp)
2205 (setq blank-line-count (1+ blank-line-count))
2206 ;; can consume all blank lines
2207 (if (>= blank-line-count n) (throw 'end-count nil) t)
2208 (zerop (forward-line 1))))
2209 (setq n blank-line-count))))))
2210 ;; construct the bottom-budget-list which is a list of numbers where each number
2211 ;; corresponds to how many lines to be deleted from the bottom of each cell. If
2212 ;; this number, say bb, is smaller than n (bb < n) that means the difference (n - bb)
2213 ;; number of lines must be deleted from the top of the cell in addition to deleting
2214 ;; bb lines from the bottom of the cell.
2215 (setq this-list coord-list)
2216 (while this-list
2217 (let ((this (prog1 (car this-list) (setq this-list (cdr this-list)))))
2218 (table--goto-coordinate (car this))
2219 (table-recognize-cell 'force)
2220 (table-with-cache-buffer
2221 (setq bottom-budget-list
2222 (cons
2223 (let ((blank-line-count 0))
2224 (table--goto-coordinate (cons 0 (1- table-cell-info-height)))
2225 (while (and (looking-at blank-line-regexp)
2226 (< blank-line-count n)
2227 (setq blank-line-count (1+ blank-line-count))
2228 (zerop (forward-line -1))))
2229 blank-line-count)
2230 bottom-budget-list)))))
2231 (setq bottom-budget-list (nreverse bottom-budget-list))
2232 ;; vertically shorten each cell from left to right
2233 (setq this-list coord-list)
2234 (while this-list
2235 (let* ((left (prog1 (car left-list) (setq left-list (if left-list (cdr left-list) coord-list))))
2236 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
2237 (right (prog1 (car right-list) (setq right-list (cdr right-list))))
2238 (bottom-budget (prog1 (car bottom-budget-list) (setq bottom-budget-list (cdr bottom-budget-list))))
2239 (exclude-left (and left (< (cddr left) (cddr this))))
2240 (exclude-right (and right (<= (cddr right) (cddr this))))
2241 (beg (table--goto-coordinate (cons (caar this) (cdar this))))
2242 (end (table--goto-coordinate (cons (cadr this) bottom-border-y)))
2243 (rect (extract-rectangle beg end))
2244 (height (+ (- (cddr this) (cdar this)) 1))
2245 (blank-line (make-string (- (cadr this) (caar this)) ?\ )))
2246 ;; delete lines from the bottom of the cell
2247 (setcdr (nthcdr (- height bottom-budget 1) rect) (nthcdr height rect))
2248 ;; delete lines from the top of the cell
2249 (if (> n bottom-budget)
2250 (let ((props (text-properties-at 0 (car rect))))
2251 (setq rect (nthcdr (- n bottom-budget) rect))
2252 (set-text-properties 0 1 props (car rect))))
2253 ;; append blank lines below the table
2254 (setq rect (append rect (make-list n blank-line)))
2255 ;; now swap the area with the prepared rect of the same size
2256 (delete-rectangle beg end)
2257 (goto-char beg)
2258 (table--insert-rectangle rect)
2259 ;; for the left and right borders always delete lines from the bottom of the cell
2260 (unless exclude-left
2261 (let* ((beg (table--goto-coordinate (cons (1- (caar this)) (cdar this))))
2262 (end (table--goto-coordinate (cons (caar this) bottom-border-y)))
2263 (rect (extract-rectangle beg end)))
2264 (setcdr (nthcdr (- height n 1) rect) (nthcdr height rect))
2265 (setq rect (append rect (make-list n " ")))
2266 (delete-rectangle beg end)
2267 (goto-char beg)
2268 (table--insert-rectangle rect)))
2269 (unless exclude-right
2270 (let* ((beg (table--goto-coordinate (cons (cadr this) (cdar this))))
2271 (end (table--goto-coordinate (cons (1+ (cadr this)) bottom-border-y)))
2272 (rect (extract-rectangle beg end)))
2273 (setcdr (nthcdr (- height n 1) rect) (nthcdr height rect))
2274 (setq rect (append rect (make-list n " ")))
2275 (delete-rectangle beg end)
2276 (goto-char beg)
2277 (table--insert-rectangle rect)))
2278 ;; if this is the cell where the original point was in, adjust the point location
2279 (if (null (equal this current-cell-coordinate)) nil
2280 (let ((y (- (cdr current-coordinate) (cdar this))))
2281 (if (< y (- n bottom-budget))
2282 (setcdr current-coordinate (cdar this))
2283 (if (< (- y (- n bottom-budget)) (- height n))
2284 (setcdr current-coordinate (+ (cdar this) (- y (- n bottom-budget))))
2285 (setcdr current-coordinate (+ (cdar this) (- height n 1)))))))))
2286 ;; remove the appended blank lines below the table if they are unnecessary
2287 (table--goto-coordinate (cons 0 (1+ (- bottom-border-y n))))
2288 (table--remove-blank-lines n)
2289 ;; re-recognize the current cell's new dimension
2290 (table--goto-coordinate current-coordinate)
2291 (table-recognize-cell 'force)
2292 (table--update-cell-heightened)
2293 (message "")))
2294
2295;;;###autoload
2296(defun table-widen-cell (n &optional no-copy no-update)
2297 "Widen the current cell by N columns and expand the cell horizontally.
2298Some other cells in the same table are widen as well to keep the
2299table's rectangle structure."
2300 (interactive "*p")
2301 (if (< n 0) (setq n 1))
2302 (let* ((coord-list (table--cell-list-to-coord-list (table--vertical-cell-list)))
2303 (below-list nil)
2304 (this-list coord-list)
2305 (above-list (cdr coord-list)))
2306 (save-excursion
2307 ;; push back the affected area above and below this table
2308 (table--horizontally-shift-above-and-below n (reverse coord-list))
2309 ;; now widen vertically for each cell
2310 (while this-list
2311 (let* ((below (prog1 (car below-list) (setq below-list (if below-list (cdr below-list) coord-list))))
2312 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
2313 (above (prog1 (car above-list) (setq above-list (cdr above-list))))
2314 (beg (table--goto-coordinate
2315 (cons (car (cdr this))
2316 (if (or (null above) (<= (car (cdr this)) (car (cdr above))))
2317 (1- (cdr (car this)))
2318 (cdr (car this))))))
2319 (end (table--goto-coordinate
2320 (cons (1+ (car (cdr this)))
2321 (if (or (null below) (< (car (cdr this)) (car (cdr below))))
2322 (1+ (cdr (cdr this)))
2323 (cdr (cdr this))))))
2324 (tmp (extract-rectangle (1- beg) end))
e99add21
JB
2325 (border (format "[%s%c]\\%c"
2326 table-cell-horizontal-chars
238240c9
RS
2327 table-cell-intersection-char
2328 table-cell-intersection-char))
2329 (blank (table--cell-blank-str))
2330 rectangle)
2331 ;; create a single wide vertical bar of empty cell fragment
2332 (while tmp
e99add21
JB
2333; (message "tmp is %s" tmp)
2334 (setq rectangle (cons
2335 (if (string-match border (car tmp))
2336 (substring (car tmp) 0 1)
238240c9
RS
2337 blank)
2338 rectangle))
e99add21 2339; (message "rectangle is %s" rectangle)
238240c9
RS
2340 (setq tmp (cdr tmp)))
2341 (setq rectangle (nreverse rectangle))
2342 ;; untabify the area right of the bar that is about to be inserted
2343 (let ((coord (table--get-coordinate beg))
2344 (i 0)
2345 (len (length rectangle)))
2346 (while (< i len)
2347 (if (table--goto-coordinate coord 'no-extension)
2348 (table--untabify-line (point)))
2349 (setcdr coord (1+ (cdr coord)))
2350 (setq i (1+ i))))
2351 ;; insert the bar n times
2352 (goto-char beg)
2353 (let ((i 0))
2354 (while (< i n)
2355 (save-excursion
2356 (table--insert-rectangle rectangle))
2357 (setq i (1+ i)))))))
2358 (table-recognize-cell 'force no-copy)
2359 (unless no-update
2360 (table--update-cell-widened))))
2361
2362;;;###autoload
2363(defun table-narrow-cell (n)
2364 "Narrow the current cell by N columns and shrink the cell horizontally.
2365Some other cells in the same table are narrowed as well to keep the
2366table's rectangle structure."
2367 (interactive "*p")
2368 (if (< n 0) (setq n 1))
2369 (table--finish-delayed-tasks)
2370 (let* ((coord-list (table--cell-list-to-coord-list (table--vertical-cell-list)))
2371 (current-cell (table--cell-to-coord (table--probe-cell)))
2372 (current-coordinate (table--get-coordinate))
2373 tmp-list)
2374 (message "Narrowing...");; this operation may be lengthy
2375 ;; determine the doable n by try narrowing each cell.
2376 (setq tmp-list coord-list)
2377 (while tmp-list
2378 (let ((cell (prog1 (car tmp-list) (setq tmp-list (cdr tmp-list))))
2379 (table-inhibit-update t)
2380 cell-n)
2381 (table--goto-coordinate (car cell))
2382 (table-recognize-cell 'force)
2383 (table-with-cache-buffer
2384 (table--fill-region (point-min) (point-max) (- table-cell-info-width n))
2385 (if (< (setq cell-n (- table-cell-info-width (table--measure-max-width))) n)
2386 (setq n cell-n))
2387 (erase-buffer)
2388 (setq table-inhibit-auto-fill-paragraph t))))
2389 (if (< n 1) nil
2390 ;; narrow only the contents of each cell but leave the cell frame as is because
2391 ;; we need to have valid frame structure in order for table-with-cache-buffer
2392 ;; to work correctly.
2393 (setq tmp-list coord-list)
2394 (while tmp-list
2395 (let* ((cell (prog1 (car tmp-list) (setq tmp-list (cdr tmp-list))))
2396 (table-inhibit-update t)
2397 (currentp (equal cell current-cell))
2398 old-height)
2399 (if currentp (table--goto-coordinate current-coordinate)
2400 (table--goto-coordinate (car cell)))
2401 (table-recognize-cell 'force)
2402 (setq old-height table-cell-info-height)
2403 (table-with-cache-buffer
2404 (let ((out-of-bound (>= (- (car current-coordinate) (car table-cell-info-lu-coordinate))
2405 (- table-cell-info-width n)))
2406 (sticky (and currentp
2407 (save-excursion
2408 (unless (bolp) (forward-char -1))
2409 (looking-at ".*\\S ")))))
2410 (table--fill-region (point-min) (point-max) (- table-cell-info-width n))
2411 (if (or sticky (and currentp (looking-at ".*\\S ")))
2412 (setq current-coordinate (table--transcoord-cache-to-table))
2413 (if out-of-bound (setcar current-coordinate
2414 (+ (car table-cell-info-lu-coordinate) (- table-cell-info-width n 1))))))
2415 (setq table-inhibit-auto-fill-paragraph t))
2416 (table--update-cell 'now)
2417 ;; if this cell heightens and pushes the current cell below, move
2418 ;; the current-coordinate (point location) down accordingly.
2419 (if currentp (setq current-coordinate (table--get-coordinate))
2420 (if (and (> table-cell-info-height old-height)
2421 (> (cdr current-coordinate) (cdr table-cell-info-lu-coordinate)))
2422 (setcdr current-coordinate (+ (cdr current-coordinate)
2423 (- table-cell-info-height old-height)))))
2424 ))
2425 ;; coord-list is now possibly invalid since some cells may have already
2426 ;; been heightened so recompute them by table--vertical-cell-list.
2427 (table--goto-coordinate current-coordinate)
2428 (setq coord-list (table--cell-list-to-coord-list (table--vertical-cell-list)))
2429 ;; push in the affected area above and below this table so that things
2430 ;; on the right side of the table are shifted horizontally neatly.
2431 (table--horizontally-shift-above-and-below (- n) (reverse coord-list))
2432 ;; finally narrow the frames for each cell.
2433 (let* ((below-list nil)
2434 (this-list coord-list)
2435 (above-list (cdr coord-list)))
2436 (while this-list
2437 (let* ((below (prog1 (car below-list) (setq below-list (if below-list (cdr below-list) coord-list))))
2438 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
2439 (above (prog1 (car above-list) (setq above-list (cdr above-list)))))
2440 (delete-rectangle
2441 (table--goto-coordinate
2442 (cons (- (cadr this) n)
2443 (if (or (null above) (<= (cadr this) (cadr above)))
2444 (1- (cdar this))
2445 (cdar this))))
2446 (table--goto-coordinate
2447 (cons (cadr this)
2448 (if (or (null below) (< (cadr this) (cadr below)))
2449 (1+ (cddr this))
2450 (cddr this)))))))))
2451 (table--goto-coordinate current-coordinate)
2452 ;; re-recognize the current cell's new dimension
2453 (table-recognize-cell 'force)
2454 (message "")))
2455
2456;;;###autoload
2457(defun table-forward-cell (&optional arg no-recognize unrecognize)
2458 "Move point forward to the beginning of the next cell.
2459With argument ARG, do it ARG times;
2460a negative argument ARG = -N means move backward N cells.
2461Do not specify NO-RECOGNIZE and UNRECOGNIZE. They are for internal use only.
2462
2463Sample Cell Traveling Order (In Irregular Table Cases)
2464
2465You can actually try how it works in this buffer. Press
2466\\[table-recognize] and go to cells in the following tables and press
2467\\[table-forward-cell] or TAB key.
2468
2469+-----+--+ +--+-----+ +--+--+--+ +--+--+--+ +---------+ +--+---+--+
2470|0 |1 | |0 |1 | |0 |1 |2 | |0 |1 |2 | |0 | |0 |1 |2 |
2471+--+--+ | | +--+--+ +--+ | | | | +--+ +----+----+ +--+-+-+--+
2472|2 |3 | | | |2 |3 | |3 +--+ | | +--+3 | |1 |2 | |3 |4 |
2473| +--+--+ +--+--+ | +--+4 | | | |4 +--+ +--+-+-+--+ +----+----+
2474| |4 | |4 | | |5 | | | | | |5 | |3 |4 |5 | |5 |
2475+--+-----+ +-----+--+ +--+--+--+ +--+--+--+ +--+---+--+ +---------+
2476
2477+--+--+--+ +--+--+--+ +--+--+--+ +--+--+--+
2478|0 |1 |2 | |0 |1 |2 | |0 |1 |2 | |0 |1 |2 |
2479| | | | | +--+ | | | | | +--+ +--+
2480+--+ +--+ +--+3 +--+ | +--+ | |3 +--+4 |
2481|3 | |4 | |4 +--+5 | | |3 | | +--+5 +--+
2482| | | | | |6 | | | | | | |6 | |7 |
2483+--+--+--+ +--+--+--+ +--+--+--+ +--+--+--+
2484
2485+--+--+--+ +--+--+--+ +--+--+--+--+ +--+-----+--+ +--+--+--+--+
2486|0 |1 |2 | |0 |1 |2 | |0 |1 |2 |3 | |0 |1 |2 | |0 |1 |2 |3 |
2487| +--+ | | +--+ | | +--+--+ | | | | | | +--+--+ |
2488| |3 +--+ +--+3 | | +--+4 +--+ +--+ +--+ +--+4 +--+
2489+--+ |4 | |4 | +--+ |5 +--+--+6 | |3 +--+--+4 | |5 | |6 |
2490|5 +--+ | | +--+5 | | |7 |8 | | | |5 |6 | | | | | |
2491| |6 | | | |6 | | +--+--+--+--+ +--+--+--+--+ +--+-----+--+
2492+--+--+--+ +--+--+--+
2493"
2494 ;; After modifying this function, test against the above tables in
2495 ;; the doc string. It is quite tricky. The tables above do not
2496 ;; mean to cover every possible cases of cell layout, of course.
2497 ;; They are examples of tricky cases from implementation point of
2498 ;; view and provided for simple regression test purpose.
2499 (interactive "p")
2500 (or arg (setq arg 1))
2501 (table--finish-delayed-tasks)
2502 (while (null (zerop arg))
2503 (let* ((pivot (table--probe-cell 'abort-on-error))
2504 (cell pivot) edge tip)
2505 ;; go to the beginning of the first right/left cell with same height if exists
2506 (while (and (setq cell (table--goto-coordinate
2507 (cons (if (> arg 0) (1+ (car (table--get-coordinate (cdr cell))))
2508 (1- (car (table--get-coordinate (car cell)))))
2509 (cdr (table--get-coordinate (car pivot)))) 'no-extension))
2510 (setq cell (table--probe-cell))
2511 (/= (cdr (table--get-coordinate (car cell)))
2512 (cdr (table--get-coordinate (car pivot))))))
2513 (if cell (goto-char (car cell)) ; done
2514 ;; if the horizontal move fails search the most left/right edge cell below/above the pivot
2515 ;; but first find the edge cell
2516 (setq edge pivot)
2517 (while (and (table--goto-coordinate
2518 (cons (if (> arg 0) (1- (car (table--get-coordinate (car edge))))
2519 (1+ (car (table--get-coordinate (cdr edge)))))
2520 (cdr (table--get-coordinate (car pivot)))) 'no-extension)
2521 (setq cell (table--probe-cell))
2522 (setq edge cell)))
2523 (setq cell (if (> arg 0) edge
2524 (or (and (table--goto-coordinate
2525 (cons (car (table--get-coordinate (cdr edge)))
2526 (1- (cdr (table--get-coordinate (car edge))))))
2527 (table--probe-cell))
2528 edge)))
2529 ;; now search for the tip which is the highest/lowest below/above cell
2530 (while cell
2531 (let (below/above)
2532 (and (table--goto-coordinate
2533 (cons (car (table--get-coordinate (if (> arg 0) (car cell)
2534 (cdr cell))))
2535 (if (> arg 0) (+ 2 (cdr (table--get-coordinate (cdr cell))))
2536 (1- (cdr (table--get-coordinate (car pivot)))))) 'no-extension)
2537 (setq below/above (table--probe-cell))
2538 (or (null tip)
2539 (if (> arg 0)
2540 (< (cdr (table--get-coordinate (car below/above)))
2541 (cdr (table--get-coordinate (car tip))))
2542 (> (cdr (table--get-coordinate (car below/above)))
2543 (cdr (table--get-coordinate (car tip))))))
2544 (setq tip below/above)))
2545 (and (setq cell (table--goto-coordinate
2546 (cons (if (> arg 0) (1+ (car (table--get-coordinate (cdr cell))))
2547 (1- (car (table--get-coordinate (car cell)))))
2548 (if (> arg 0) (cdr (table--get-coordinate (car pivot)))
2549 (1- (cdr (table--get-coordinate (car pivot)))))) 'no-extension))
2550 (setq cell (table--probe-cell))))
2551 (if tip (goto-char (car tip)) ; done
2552 ;; let's climb up/down to the top/bottom from the edge
2553 (while (and (table--goto-coordinate
2554 (cons (if (> arg 0) (car (table--get-coordinate (car edge)))
2555 (car (table--get-coordinate (cdr edge))))
2556 (if (> arg 0) (1- (cdr (table--get-coordinate (car edge))))
2557 (+ 2 (cdr (table--get-coordinate (cdr edge)))))) 'no-extension)
2558 (setq cell (table--probe-cell))
2559 (setq edge cell)))
2560 (if (< arg 0)
2561 (progn
2562 (setq cell edge)
2563 (while (and (table--goto-coordinate
2564 (cons (1- (car (table--get-coordinate (car cell))))
2565 (cdr (table--get-coordinate (cdr cell)))) 'no-extension)
2566 (setq cell (table--probe-cell)))
2567 (if (> (cdr (table--get-coordinate (car cell)))
2568 (cdr (table--get-coordinate (car edge))))
2569 (setq edge cell)))))
2570 (goto-char (car edge))))) ; the top left cell
2571 (setq arg (if (> arg 0) (1- arg) (1+ arg))))
2572 (unless no-recognize
2573 (table-recognize-cell 'force nil (if unrecognize -1 nil)))) ; refill the cache with new cell contents
2574
2575;;;###autoload
2576(defun table-backward-cell (&optional arg)
2577 "Move backward to the beginning of the previous cell.
2578With argument ARG, do it ARG times;
2579a negative argument ARG = -N means move forward N cells."
2580 (interactive "p")
2581 (or arg (setq arg 1))
2582 (table-forward-cell (- arg)))
2583
2584;;;###autoload
2585(defun table-span-cell (direction)
2586 "Span current cell into adjacent cell in DIRECTION.
2587DIRECTION is one of symbols; right, left, above or below."
2588 (interactive
2589 (list
2590 (let* ((dummy (barf-if-buffer-read-only))
2591 (direction-list
2592 (let* ((tmp (delete nil
2593 (mapcar (lambda (d)
2594 (if (table--cell-can-span-p d)
2595 (list (symbol-name d))))
2596 '(right left above below)))))
2597 (if (null tmp)
2598 (error "Can't span this cell"))
2599 tmp))
2600 (default-direction (if (member (list (car table-cell-span-direction-history)) direction-list)
2601 (car table-cell-span-direction-history)
2602 (caar direction-list)))
2603 (completion-ignore-case t))
2604 (intern (downcase (completing-read
2605 (format "Span into (default %s): " default-direction)
2606 direction-list
2607 nil t nil 'table-cell-span-direction-history default-direction))))))
2608 (unless (memq direction '(right left above below))
2609 (error "Invalid direction %s, must be right, left, above or below"
2610 (symbol-name direction)))
2611 (table-recognize-cell 'force)
2612 (unless (table--cell-can-span-p direction)
2613 (error "Can't span %s" (symbol-name direction)))
2614 ;; prepare beginning and ending positions of the border bar to strike through
2615 (let ((beg (cond
2616 ((eq direction 'right)
2617 (save-excursion
2618 (table--goto-coordinate
2619 (cons (car table-cell-info-rb-coordinate)
2620 (1- (cdr table-cell-info-lu-coordinate))) 'no-extension)))
2621 ((eq direction 'below)
2622 (save-excursion
2623 (table--goto-coordinate
2624 (cons (1- (car table-cell-info-lu-coordinate))
2625 (1+ (cdr table-cell-info-rb-coordinate))) 'no-extension)))
2626 (t
2627 (save-excursion
2628 (table--goto-coordinate
2629 (cons (1- (car table-cell-info-lu-coordinate))
2630 (1- (cdr table-cell-info-lu-coordinate))) 'no-extension)))))
2631 (end (cond
2632 ((eq direction 'left)
2633 (save-excursion
2634 (table--goto-coordinate
2635 (cons (car table-cell-info-lu-coordinate)
2636 (1+ (cdr table-cell-info-rb-coordinate))) 'no-extension)))
2637 ((eq direction 'above)
2638 (save-excursion
2639 (table--goto-coordinate
2640 (cons (1+ (car table-cell-info-rb-coordinate))
2641 (1- (cdr table-cell-info-lu-coordinate))) 'no-extension)))
2642 (t
2643 (save-excursion
2644 (table--goto-coordinate
2645 (cons (1+ (car table-cell-info-rb-coordinate))
2646 (1+ (cdr table-cell-info-rb-coordinate))) 'no-extension))))))
2647 ;; replace the bar with blank space while taking care of edges to be border or intersection
2648 (save-excursion
2649 (goto-char beg)
2650 (if (memq direction '(left right))
2651 (let* ((column (current-column))
2652 rectangle
2653 (n-element (- (length (extract-rectangle beg end)) 2))
2654 (above-contp (and (goto-char beg)
2655 (zerop (forward-line -1))
2656 (= (move-to-column column) column)
2657 (looking-at (regexp-quote (char-to-string table-cell-vertical-char)))))
2658 (below-contp (and (goto-char end)
2659 (progn (forward-char -1) t)
2660 (zerop (forward-line 1))
2661 (= (move-to-column column) column)
2662 (looking-at (regexp-quote (char-to-string table-cell-vertical-char))))))
2663 (setq rectangle
2664 (cons (if below-contp
2665 (char-to-string table-cell-intersection-char)
e99add21 2666 (substring table-cell-horizontal-chars 0 1))
238240c9
RS
2667 rectangle))
2668 (while (> n-element 0)
2669 (setq rectangle (cons (table--cell-blank-str 1) rectangle))
2670 (setq n-element (1- n-element)))
2671 (setq rectangle
2672 (cons (if above-contp
2673 (char-to-string table-cell-intersection-char)
e99add21 2674 (substring table-cell-horizontal-chars 0 1))
238240c9
RS
2675 rectangle))
2676 (delete-rectangle beg end)
2677 (goto-char beg)
2678 (table--insert-rectangle rectangle))
2679 (delete-region beg end)
2680 (insert (if (and (> (point) (point-min))
2681 (save-excursion
2682 (forward-char -1)
e99add21
JB
2683 (looking-at (regexp-opt-charset
2684 (string-to-list table-cell-horizontal-chars)))))
238240c9
RS
2685 table-cell-intersection-char
2686 table-cell-vertical-char)
2687 (table--cell-blank-str (- end beg 2))
e99add21
JB
2688 (if (looking-at (regexp-opt-charset
2689 (string-to-list table-cell-horizontal-chars)))
238240c9
RS
2690 table-cell-intersection-char
2691 table-cell-vertical-char))))
2692 ;; recognize the newly created spanned cell
2693 (table-recognize-cell 'force)
2694 (if (member direction '(right left))
2695 (table-with-cache-buffer
2696 (table--fill-region (point-min) (point-max))
2697 (setq table-inhibit-auto-fill-paragraph t)))))
2698
2699;;;###autoload
2700(defun table-split-cell-vertically ()
2701 "Split current cell vertically.
2702Creates a cell above and a cell below the current point location."
2703 (interactive "*")
2704 (table-recognize-cell 'force)
2705 (let ((point-y (cdr (table--get-coordinate))))
2706 (unless (table--cell-can-split-vertically-p)
2707 (error "Can't split here"))
2708 (let* ((old-coordinate (table--get-coordinate))
2709 (column (current-column))
2710 (beg (table--goto-coordinate
2711 (cons (1- (car table-cell-info-lu-coordinate))
2712 point-y)))
2713 (end (table--goto-coordinate
2714 (cons (1+ (car table-cell-info-rb-coordinate))
2715 point-y)))
2716 (line (buffer-substring (1+ beg) (1- end))))
2717 (when (= (cdr old-coordinate) (cdr table-cell-info-rb-coordinate))
2718 (table--goto-coordinate old-coordinate)
2719 (table-heighten-cell 1 'no-copy 'no-update))
2720 (goto-char beg)
2721 (delete-region beg end)
2722 (insert table-cell-intersection-char
e99add21 2723 (make-string table-cell-info-width (string-to-char table-cell-horizontal-chars))
238240c9
RS
2724 table-cell-intersection-char)
2725 (table--goto-coordinate old-coordinate)
2726 (forward-line 1)
2727 (move-to-column column)
2728 (setq old-coordinate (table--get-coordinate))
2729 (table-recognize-cell 'force)
2730 (unless (string-match "^\\s *$" line)
2731 (table-with-cache-buffer
2732 (goto-char (point-min))
2733 (insert line ?\n)
2734 (goto-char (point-min)) ;; don't heighten cell unnecessarily
2735 (setq table-inhibit-auto-fill-paragraph t)))
2736 (table--update-cell 'now) ;; can't defer this operation
2737 (table--goto-coordinate old-coordinate)
2738 (move-to-column column)
2739 (table-recognize-cell 'force))))
2740
2741;;;###autoload
2742(defun table-split-cell-horizontally ()
2743 "Split current cell horizontally.
2744Creates a cell on the left and a cell on the right of the current point location."
2745 (interactive "*")
2746 (table-recognize-cell 'force)
2747 (let* ((o-coordinate (table--get-coordinate))
2748 (point-x (car o-coordinate))
2749 cell-empty cell-contents cell-coordinate
2750 contents-to beg end rectangle strip-rect
2751 (right-edge (= (car o-coordinate) (1- (car table-cell-info-rb-coordinate)))))
2752 (unless (table--cell-can-split-horizontally-p)
2753 (error "Can't split here"))
2754 (let ((table-inhibit-update t))
2755 (table-with-cache-buffer
2756 (setq cell-coordinate (table--get-coordinate))
2757 (save-excursion
2758 (goto-char (point-min))
2759 (setq cell-empty (null (re-search-forward "\\S " nil t))))
2760 (setq cell-contents (buffer-substring (point-min) (point-max)))
2761 (setq table-inhibit-auto-fill-paragraph t)))
2762 (setq contents-to
2763 (if cell-empty 'left
2764 (let* ((completion-ignore-case t)
2765 (default (car table-cell-split-contents-to-history)))
2766 (intern
2767 (if (member 'click (event-modifiers last-input-event))
2768 (x-popup-menu last-input-event
2769 '("Existing cell contents to:"
2770 ("Title"
2771 ("Split" . "split") ("Left" . "left") ("Right" . "right"))))
2772 (downcase (completing-read
2773 (format "Existing cell contents to (default %s): " default)
2774 '(("split") ("left") ("right"))
2775 nil t nil 'table-cell-split-contents-to-history default)))))))
2776 (unless (eq contents-to 'split)
2777 (table-with-cache-buffer
2778 (erase-buffer)
2779 (setq table-inhibit-auto-fill-paragraph t)))
2780 (table--update-cell 'now)
2781 (setq beg (table--goto-coordinate
2782 (cons point-x
2783 (1- (cdr table-cell-info-lu-coordinate)))))
2784 (setq end (table--goto-coordinate
2785 (cons (1+ point-x)
2786 (1+ (cdr table-cell-info-rb-coordinate)))))
2787 (setq rectangle (cons (char-to-string table-cell-intersection-char) nil))
2788 (let ((n table-cell-info-height))
2789 (while (prog1 (> n 0) (setq n (1- n)))
2790 (setq rectangle (cons (char-to-string table-cell-vertical-char) rectangle))))
2791 (setq rectangle (cons (char-to-string table-cell-intersection-char) rectangle))
2792 (if (eq contents-to 'split)
2793 (setq strip-rect (extract-rectangle beg end)))
2794 (delete-rectangle beg end)
2795 (goto-char beg)
2796 (table--insert-rectangle rectangle)
2797 (table--goto-coordinate o-coordinate)
2798 (if cell-empty
2799 (progn
2800 (forward-char 1)
2801 (if right-edge
2802 (table-widen-cell 1)))
2803 (unless (eq contents-to 'left)
2804 (forward-char 1))
2805 (table-recognize-cell 'force)
2806 (table-with-cache-buffer
2807 (if (eq contents-to 'split)
2808 ;; split inserts strip-rect after removing
2809 ;; top and bottom borders
2810 (let ((o-coord (table--get-coordinate))
2811 (l (setq strip-rect (cdr strip-rect))))
2812 (while (cddr l) (setq l (cdr l)))
2813 (setcdr l nil)
2814 ;; insert the strip only when it is not a completely blank one
2815 (unless (let ((cl (mapcar (lambda (s) (string= s " ")) strip-rect)))
2816 (and (car cl)
2817 (table--uniform-list-p cl)))
2818 (goto-char (point-min))
2819 (table--insert-rectangle strip-rect)
2820 (table--goto-coordinate o-coord)))
2821 ;; left or right inserts original contents
2822 (erase-buffer)
2823 (insert cell-contents)
2824 (table--goto-coordinate cell-coordinate)
2825 (table--fill-region (point-min) (point-max))
2826 ;; avoid unnecessary vertical cell expansion
2827 (and (looking-at "\\s *\\'")
2828 (re-search-backward "\\S \\(\\s *\\)\\=" nil t)
2829 (goto-char (match-beginning 1))))
2830 ;; in either case do not fill paragraph
2831 (setq table-inhibit-auto-fill-paragraph t))
2832 (table--update-cell 'now)) ;; can't defer this operation
2833 (table-recognize-cell 'force)))
2834
2835;;;###autoload
2836(defun table-split-cell (orientation)
2837 "Split current cell in ORIENTATION.
2838ORIENTATION is a symbol either horizontally or vertically."
2839 (interactive
2840 (list
2841 (let* ((dummy (barf-if-buffer-read-only))
2842 (completion-ignore-case t)
2843 (default (car table-cell-split-orientation-history)))
2844 (intern (downcase (completing-read
2845 (format "Split orientation (default %s): " default)
2846 '(("horizontally") ("vertically"))
2847 nil t nil 'table-cell-split-orientation-history default))))))
2848 (unless (memq orientation '(horizontally vertically))
2849 (error "Invalid orientation %s, must be horizontally or vertically"
2850 (symbol-name orientation)))
2851 (if (eq orientation 'horizontally)
2852 (table-split-cell-horizontally)
2853 (table-split-cell-vertically)))
2854
2855;;;###autoload
2856(defun table-justify (what justify)
2857 "Justify contents of a cell, a row of cells or a column of cells.
2858WHAT is a symbol 'cell, 'row or 'column. JUSTIFY is a symbol 'left,
2859'center, 'right, 'top, 'middle, 'bottom or 'none."
2860 (interactive
2861 (list (let* ((dummy (barf-if-buffer-read-only))
2862 (completion-ignore-case t)
2863 (default (car table-target-history)))
2864 (intern (downcase (completing-read
2865 (format "Justify what (default %s): " default)
2866 '(("cell") ("row") ("column"))
2867 nil t nil 'table-target-history default))))
2868 (table--query-justification)))
2869 (funcall (intern (concat "table-justify-" (symbol-name what))) justify))
2870
2871;;;###autoload
2872(defun table-justify-cell (justify &optional paragraph)
2873 "Justify cell contents.
2874JUSTIFY is a symbol 'left, 'center or 'right for horizontal, or 'top,
2875'middle, 'bottom or 'none for vertical. When optional PARAGRAPH is
2876non-nil the justify operation is limited to the current paragraph,
2877otherwise the entire cell contents is justified."
2878 (interactive
2879 (list (table--query-justification)))
2880 (table--finish-delayed-tasks)
2881 (table-recognize-cell 'force)
2882 (table--justify-cell-contents justify paragraph))
2883
2884;;;###autoload
2885(defun table-justify-row (justify)
2886 "Justify cells of a row.
2887JUSTIFY is a symbol 'left, 'center or 'right for horizontal, or top,
2888'middle, 'bottom or 'none for vertical."
2889 (interactive
2890 (list (table--query-justification)))
2891 (let((cell-list (table--horizontal-cell-list nil nil 'top)))
2892 (table--finish-delayed-tasks)
2893 (save-excursion
2894 (while cell-list
2895 (let ((cell (car cell-list)))
2896 (setq cell-list (cdr cell-list))
2897 (goto-char (car cell))
2898 (table-recognize-cell 'force)
2899 (table--justify-cell-contents justify))))))
2900
2901;;;###autoload
2902(defun table-justify-column (justify)
2903 "Justify cells of a column.
2904JUSTIFY is a symbol 'left, 'center or 'right for horizontal, or top,
2905'middle, 'bottom or 'none for vertical."
2906 (interactive
2907 (list (table--query-justification)))
2908 (let((cell-list (table--vertical-cell-list nil nil 'left)))
2909 (table--finish-delayed-tasks)
2910 (save-excursion
2911 (while cell-list
2912 (let ((cell (car cell-list)))
2913 (setq cell-list (cdr cell-list))
2914 (goto-char (car cell))
2915 (table-recognize-cell 'force)
2916 (table--justify-cell-contents justify))))))
2917
2918;;;###autoload
2919(defun table-fixed-width-mode (&optional arg)
2920 "Toggle fixing width mode.
2921In the fixed width mode, typing inside a cell never changes the cell
2922width where in the normal mode the cell width expands automatically in
2923order to prevent a word being folded into multiple lines."
2924 (interactive "P")
2925 (table--finish-delayed-tasks)
2926 (setq table-fixed-width-mode
2927 (if (null arg)
2928 (not table-fixed-width-mode)
2929 (> (prefix-numeric-value arg) 0)))
2930 (save-excursion
2931 (mapcar (lambda (buf)
2932 (set-buffer buf)
2933 (if (table--point-in-cell-p)
2934 (table--point-entered-cell-function)))
2935 (buffer-list)))
2936 (table--update-cell-face))
2937
2938;;;###autoload
2939(defun table-query-dimension (&optional where)
2940 "Return the dimension of the current cell and the current table.
2941The result is a list (cw ch tw th c r cells) where cw is the cell
2942width, ch is the cell height, tw is the table width, th is the table
2943height, c is the number of columns, r is the number of rows and cells
2944is the total number of cells. The cell dimension excludes the cell
2945frame while the table dimension includes the table frame. The columns
2946and the rows are counted by the number of cell boundaries. Therefore
2947the number tends to be larger than it appears for the tables with
2948non-uniform cell structure (heavily spanned and split). When optional
2949WHERE is provided the cell and table at that location is reported."
2950 (interactive)
2951 (save-excursion
2952 (if where (goto-char where))
2953 (let ((starting-cell (table--probe-cell))
2954 cell table-lu table-rb col-list row-list (cells 0))
2955 (if (null starting-cell) nil
2956 (setq table-lu (car starting-cell))
2957 (setq table-rb (cdr starting-cell))
2958 (setq col-list (cons (car (table--get-coordinate (car starting-cell))) nil))
2959 (setq row-list (cons (cdr (table--get-coordinate (car starting-cell))) nil))
2960 (and (interactive-p)
2961 (message "Computing cell dimension..."))
2962 (while
2963 (progn
2964 (table-forward-cell 1 t)
2965 (setq cells (1+ cells))
2966 (and (setq cell (table--probe-cell))
2967 (not (equal cell starting-cell))))
2968 (if (< (car cell) table-lu)
2969 (setq table-lu (car cell)))
2970 (if (> (cdr cell) table-rb)
2971 (setq table-rb (cdr cell)))
2972 (let ((lu-coordinate (table--get-coordinate (car cell))))
2973 (if (memq (car lu-coordinate) col-list) nil
2974 (setq col-list (cons (car lu-coordinate) col-list)))
2975 (if (memq (cdr lu-coordinate) row-list) nil
2976 (setq row-list (cons (cdr lu-coordinate) row-list)))))
2977 (let* ((cell-lu-coordinate (table--get-coordinate (car starting-cell)))
2978 (cell-rb-coordinate (table--get-coordinate (cdr starting-cell)))
2979 (table-lu-coordinate (table--get-coordinate table-lu))
2980 (table-rb-coordinate (table--get-coordinate table-rb))
2981 (cw (- (car cell-rb-coordinate) (car cell-lu-coordinate)))
2982 (ch (1+ (- (cdr cell-rb-coordinate) (cdr cell-lu-coordinate))))
2983 (tw (+ 2 (- (car table-rb-coordinate) (car table-lu-coordinate))))
2984 (th (+ 3 (- (cdr table-rb-coordinate) (cdr table-lu-coordinate))))
2985 (c (length col-list))
2986 (r (length row-list)))
2987 (and (interactive-p)
2988 (message "Cell: (%dw, %dh), Table: (%dw, %dh), Dim: (%dc, %dr), Total Cells: %d" cw ch tw th c r cells))
2989 (list cw ch tw th c r cells))))))
2990
2991;;;###autoload
2992(defun table-generate-source (language &optional dest-buffer caption)
2993 "Generate source of the current table in the specified language.
2994LANGUAGE is a symbol that specifies the language to describe the
2995structure of the table. It must be either 'html, 'latex or 'cals.
2996The resulted source text is inserted into DEST-BUFFER and the buffer
2997object is returned. When DEST-BUFFER is omitted or nil the default
2998buffer specified in `table-dest-buffer-name' is used. In this case
2999the content of the default buffer is erased prior to the generation.
3000When DEST-BUFFER is non-nil it is expected to be either a destination
3001buffer or a name of the destination buffer. In this case the
3002generated result is inserted at the current point in the destination
3003buffer and the previously existing contents in the buffer are
3004untouched.
3005
3006References used for this implementation:
3007
3008HTML:
3009 http://www.w3.org
3010
3011LaTeX:
3012 http://www.maths.tcd.ie/~dwilkins/LaTeXPrimer/Tables.html
3013
3014CALS (DocBook DTD):
3015 http://www.oasis-open.org/html/a502.htm
3016 http://www.oreilly.com/catalog/docbook/chapter/book/table.html#AEN114751
3017"
3018 (interactive
3019 (let* ((dummy (unless (table--probe-cell) (error "Table not found here")))
3020 (completion-ignore-case t)
3021 (default (car table-source-language-history))
3022 (language (downcase (completing-read
3023 (format "Language (default %s): " default)
3024 (mapcar (lambda (s) (list (symbol-name s)))
3025 table-source-languages)
3026 nil t nil 'table-source-language-history default))))
3027 (list
3028 (intern language)
3029 (read-buffer "Destination buffer: " (concat table-dest-buffer-name "." language))
3030 (table--read-from-minibuffer '("Table Caption" . table-source-caption-history)))))
3031 (let ((default-buffer-name (concat table-dest-buffer-name "." (symbol-name language))))
3032 (unless (or (interactive-p) (table--probe-cell)) (error "Table not found here"))
3033 (unless (bufferp dest-buffer)
3034 (setq dest-buffer (get-buffer-create (or dest-buffer default-buffer-name))))
3035 (if (string= (buffer-name dest-buffer) default-buffer-name)
3036 (with-current-buffer dest-buffer
3037 (erase-buffer)))
3038 (save-excursion
3039 (let ((starting-cell (table--probe-cell))
3040 cell origin-cell tail-cell col-list row-list (n 0) i)
3041 ;; first analyze the table structure and prepare:
3042 ;; 1. origin cell (left up corner cell)
3043 ;; 2. tail cell (right bottom corner cell)
3044 ;; 3. column boundary list
3045 ;; 4. row boundary list
3046 (setq origin-cell starting-cell)
3047 (setq tail-cell starting-cell)
3048 (setq col-list (cons (car (table--get-coordinate (car starting-cell))) nil))
3049 (setq row-list (cons (cdr (table--get-coordinate (car starting-cell))) nil))
3050 (setq i 0)
4fb81250 3051 (let ((wheel [?- ?\\ ?| ?/]))
238240c9
RS
3052 (while
3053 (progn
3054 (if (interactive-p)
3055 (progn
3056 (message "Analyzing table...%c" (aref wheel i))
3057 (if (eq (setq i (1+ i)) (length wheel))
3058 (setq i 0))
3059 (setq n (1+ n))))
3060 (table-forward-cell 1 t)
3061 (and (setq cell (table--probe-cell))
3062 (not (equal cell starting-cell))))
3063 (if (< (car cell) (car origin-cell))
3064 (setq origin-cell cell))
3065 (if (> (cdr cell) (cdr tail-cell))
3066 (setq tail-cell cell))
3067 (let ((lu-coordinate (table--get-coordinate (car cell))))
3068 (unless (memq (car lu-coordinate) col-list)
3069 (setq col-list (cons (car lu-coordinate) col-list)))
3070 (unless (memq (cdr lu-coordinate) row-list)
3071 (setq row-list (cons (cdr lu-coordinate) row-list))))))
3072 (setq col-list (sort col-list '<))
3073 (setq row-list (sort row-list '<))
3074 (message "Generating source...")
3075 ;; clear the source generation property list
3076 (setplist 'table-source-info-plist nil)
3077 ;; prepare to start from the origin cell
3078 (goto-char (car origin-cell))
3079 ;; first put some header information
3080 (table--generate-source-prologue dest-buffer language caption col-list row-list)
3081 (cond
3082 ((eq language 'latex)
3083 ;; scan by character lines
3084 (table--generate-source-scan-lines dest-buffer language origin-cell tail-cell col-list row-list))
3085 (t
3086 ;; scan by table cells
3087 (table--generate-source-scan-rows dest-buffer language origin-cell col-list row-list)))
3088 ;; insert closing
3089 (table--generate-source-epilogue dest-buffer language col-list row-list))
3090 ;; lastly do some convenience work
3091 (if (interactive-p)
3092 (save-selected-window
3093 (pop-to-buffer dest-buffer t)
3094 (goto-char (point-min))
3095 (and (string= (buffer-name dest-buffer) default-buffer-name)
3096 (buffer-file-name dest-buffer)
3097 (save-buffer))
3098 (message "Generating source...done")
3099 (let ((mode
3100 (if (memq language '(cals)) 'sgml-mode
3101 (intern (concat (symbol-name language) "-mode")))))
3102 (if (fboundp mode)
3103 (call-interactively mode)))
3104 )))
3105 dest-buffer))
3106
3107(defun table--generate-source-prologue (dest-buffer language caption col-list row-list)
3108 "Generate and insert source prologue into DEST-BUFFER."
3109 (with-current-buffer dest-buffer
3110 (cond
3111 ((eq language 'html)
3112 (insert (format "<!-- This HTML table template is generated by emacs %s -->\n" emacs-version)
3113 (format "<TABLE %s>\n" table-html-table-attribute)
3114 (if (and (stringp caption)
3115 (not (string= caption "")))
3116 (format " <CAPTION>%s</CAPTION>\n" caption)
3117 "")))
3118 ((eq language 'latex)
3119 (insert (format "%% This LaTeX table template is generated by emacs %s\n" emacs-version)
3120 "\\begin{tabular}{|" (apply 'concat (make-list (length col-list) "l|")) "}\n"
3121 "\\hline\n"))
3122 ((eq language 'cals)
3123 (insert (format "<!-- This CALS table template is generated by emacs %s -->\n" emacs-version)
3124 "<table frame=\"all\">\n")
3125 (if (and (stringp caption)
3126 (not (string= caption "")))
3127 (insert " <title>" caption "</title>\n"))
3128 (insert (format " <tgroup cols=\"%d\" align=\"left\" colsep=\"1\" rowsep=\"1\">\n" (length col-list)))
3129 (table-put-source-info 'colspec-marker (point-marker))
3130 (table-put-source-info 'row-type (if (zerop table-cals-thead-rows) "tbody" "thead"))
3131 (set-marker-insertion-type (table-get-source-info 'colspec-marker) nil) ;; insert after
3132 (insert (format " <%s valign=\"top\">\n" (table-get-source-info 'row-type))))
3133 )))
3134
3135(defun table--generate-source-epilogue (dest-buffer language col-list row-list)
3136 "Generate and insert source epilogue into DEST-BUFFER."
3137 (with-current-buffer dest-buffer
3138 (cond
3139 ((eq language 'html)
3140 (insert "</TABLE>\n"))
3141 ((eq language 'latex)
3142 (insert "\\end{tabular}\n"))
3143 ((eq language 'cals)
3144 (set-marker-insertion-type (table-get-source-info 'colspec-marker) t) ;; insert before
3145 (save-excursion
3146 (goto-char (table-get-source-info 'colspec-marker))
3147 (mapcar
3148 (lambda (col)
3149 (insert (format " <colspec colnum=\"%d\" colname=\"c%d\"/>\n" col col)))
3150 (sort (table-get-source-info 'colnum-list) '<)))
3151 (insert (format " </%s>\n </tgroup>\n</table>\n" (table-get-source-info 'row-type))))
3152 )))
3153
3154(defun table--generate-source-scan-rows (dest-buffer language origin-cell col-list row-list)
3155 "Generate and insert source rows into DEST-BUFFER."
3156 (table-put-source-info 'current-row 1)
3157 (while row-list
3158 (with-current-buffer dest-buffer
3159 (cond
3160 ((eq language 'html)
3161 (insert " <TR>\n"))
3162 ((eq language 'cals)
3163 (insert " <row>\n"))
3164 ))
3165 (table--generate-source-cells-in-a-row dest-buffer language col-list row-list)
3166 (with-current-buffer dest-buffer
3167 (cond
3168 ((eq language 'html)
3169 (insert " </TR>\n"))
3170 ((eq language 'cals)
3171 (insert " </row>\n")
3172 (unless (/= (table-get-source-info 'current-row) table-cals-thead-rows)
db95369b 3173 (insert (format " </%s>\n" (table-get-source-info 'row-type)))
238240c9
RS
3174 (insert (format " <%s valign=\"top\">\n" (table-put-source-info 'row-type "tbody")))))))
3175 (table-put-source-info 'current-row (1+ (table-get-source-info 'current-row)))
3176 (setq row-list (cdr row-list))))
3177
3178(defun table--generate-source-cells-in-a-row (dest-buffer language col-list row-list)
3179 "Generate and insert source cells into DEST-BUFFER."
3180 (table-put-source-info 'current-column 1)
3181 (while col-list
3182 (let* ((cell (table--probe-cell))
3183 (lu (table--get-coordinate (car cell)))
3184 (rb (table--get-coordinate (cdr cell)))
3185 (alignment (table--get-cell-justify-property cell))
3186 (valign (table--get-cell-valign-property cell))
3187 (row-list row-list)
3188 (colspan 1)
3189 (rowspan 1))
3190 (if (< (car lu) (car col-list))
3191 (setq col-list nil)
3192 (while (and col-list
3193 (> (car lu) (car col-list)))
3194 (setq col-list (cdr col-list))
3195 (table-put-source-info 'current-column (1+ (table-get-source-info 'current-column))))
3196 (setq col-list (cdr col-list))
3197 (table-put-source-info 'next-column (1+ (table-get-source-info 'current-column)))
3198 (while (and col-list
3199 (> (1+ (car rb)) (car col-list)))
3200 (setq colspan (1+ colspan))
3201 (setq col-list (cdr col-list))
3202 (table-put-source-info 'next-column (1+ (table-get-source-info 'next-column))))
3203 (setq row-list (cdr row-list))
3204 (while (and row-list
3205 (> (+ (cdr rb) 2) (car row-list)))
3206 (setq rowspan (1+ rowspan))
3207 (setq row-list (cdr row-list)))
3208 (with-current-buffer dest-buffer
3209 (cond
3210 ((eq language 'html)
3211 (insert (format " <%s"
3212 (table-put-source-info
3213 'cell-type
3214 (if (or (<= (table-get-source-info 'current-row) table-html-th-rows)
3215 (<= (table-get-source-info 'current-column) table-html-th-columns))
3216 "TH" "TD"))))
3217 (if (and table-html-cell-attribute (not (string= table-html-cell-attribute "")))
3218 (insert " " table-html-cell-attribute))
3219 (if (> colspan 1) (insert (format " colspan=\"%d\"" colspan)))
3220 (if (> rowspan 1) (insert (format " rowspan=\"%d\"" rowspan)))
3221 (insert (format " align=\"%s\"" (if alignment (symbol-name alignment) "left")))
3222 (insert (format " valign=\"%s\"" (if valign (symbol-name valign) "top")))
3223 (insert ">\n"))
3224 ((eq language 'cals)
3225 (insert " <entry")
3226 (if (> colspan 1)
3227 (let ((scol (table-get-source-info 'current-column))
3228 (ecol (+ (table-get-source-info 'current-column) colspan -1)))
3229 (mapcar (lambda (col)
3230 (unless (memq col (table-get-source-info 'colnum-list))
3231 (table-put-source-info 'colnum-list
3232 (cons col (table-get-source-info 'colnum-list)))))
3233 (list scol ecol))
3234 (insert (format " namest=\"c%d\" nameend=\"c%d\"" scol ecol))))
3235 (if (> rowspan 1) (insert (format " morerows=\"%d\"" (1- rowspan))))
3236 (if (and alignment
3237 (not (memq alignment '(left none))))
3238 (insert " align=\"" (symbol-name alignment) "\""))
3239 (if (and valign
3240 (not (memq valign '(top none))))
3241 (insert " valign=\"" (symbol-name valign) "\""))
3242 (insert ">\n"))
3243 ))
3244 (table--generate-source-cell-contents dest-buffer language cell)
3245 (with-current-buffer dest-buffer
3246 (cond
3247 ((eq language 'html)
3248 (insert (format" </%s>\n" (table-get-source-info 'cell-type))))
3249 ((eq language 'cals)
3250 (insert " </entry>\n"))
3251 ))
3252 (table-forward-cell 1 t)
3253 (table-put-source-info 'current-column (table-get-source-info 'next-column))
3254 ))))
3255
3256(defun table--generate-source-cell-contents (dest-buffer language cell)
3257 "Generate and insert source cell contents of a CELL into DEST-BUFFER."
3258 (let ((cell-contents (extract-rectangle (car cell) (cdr cell))))
3259 (with-temp-buffer
3260 (table--insert-rectangle cell-contents)
3261 (table--remove-cell-properties (point-min) (point-max))
3262 (goto-char (point-min))
3263 (cond
3264 ((eq language 'html)
3265 (if table-html-delegate-spacing-to-user-agent
3266 (progn
3267 (table--remove-eol-spaces (point-min) (point-max))
3268 (if (re-search-forward "\\s +\\'" nil t)
3269 (replace-match "")))
3270 (while (search-forward " " nil t)
3271 (replace-match "&nbsp;"))
3272 (goto-char (point-min))
3273 (while (and (re-search-forward "$" nil t)
3274 (not (eobp)))
3275 (insert "<BR />")
3276 (forward-char 1)))
3277 (unless (and table-html-delegate-spacing-to-user-agent
3278 (progn
3279 (goto-char (point-min))
3280 (looking-at "\\s *\\'")))))
3281 ((eq language 'cals)
3282 (table--remove-eol-spaces (point-min) (point-max))
3283 (if (re-search-forward "\\s +\\'" nil t)
3284 (replace-match "")))
3285 )
3286 (setq cell-contents (buffer-substring (point-min) (point-max))))
3287 (with-current-buffer dest-buffer
3288 (let ((beg (point)))
3289 (insert cell-contents)
3290 (indent-rigidly beg (point)
3291 (cond
3292 ((eq language 'html) 6)
3293 ((eq language 'cals) 10)))
3294 (insert ?\n)))))
3295
e99add21
JB
3296(defun table--cell-horizontal-char-p (c)
3297 "Test if character C is one of the horizontal characters"
3298 (memq c (string-to-list table-cell-horizontal-chars)))
3299
238240c9
RS
3300(defun table--generate-source-scan-lines (dest-buffer language origin-cell tail-cell col-list row-list)
3301 "Scan the table line by line.
3302Currently this method is for LaTeX only."
3303 (let* ((lu-coord (table--get-coordinate (car origin-cell)))
3304 (rb-coord (table--get-coordinate (cdr tail-cell)))
3305 (x0 (car lu-coord))
3306 (x1 (car rb-coord))
3307 (y (cdr lu-coord))
3308 (y1 (cdr rb-coord)))
3309 (while (<= y y1)
3310 (let* ((border-p (memq (1+ y) row-list))
3311 (border-char-list
3312 (mapcar (lambda (x)
3313 (if border-p (char-after (table--goto-coordinate (cons x y)))
3314 (char-before (table--goto-coordinate (cons x y)))))
3315 col-list))
3316 start i c)
3317 (if border-p
3318 ;; horizontal cell border processing
e99add21 3319 (if (and (table--cell-horizontal-char-p (car border-char-list))
238240c9
RS
3320 (table--uniform-list-p border-char-list))
3321 (with-current-buffer dest-buffer
3322 (insert "\\hline\n"))
3323 (setq i 0)
3324 (while (setq c (nth i border-char-list))
e99add21 3325 (if (and start (not (table--cell-horizontal-char-p c)))
238240c9
RS
3326 (progn
3327 (with-current-buffer dest-buffer
3328 (insert (format "\\cline{%d-%d}\n" (1+ start) i)))
3329 (setq start nil)))
e99add21 3330 (if (and (not start) (table--cell-horizontal-char-p c))
238240c9
RS
3331 (setq start i))
3332 (setq i (1+ i)))
3333 (if start
3334 (with-current-buffer dest-buffer
3335 (insert (format "\\cline{%d-%d}\n" (1+ start) i)))))
3336 ;; horizontal cell contents processing
3337 (let* ((span 1) ;; spanning length
3338 (first-p t) ;; first in a row
3339 (insert-column ;; a function that processes one column/multicolumn
3340 (function
3341 (lambda (from to)
3342 (let ((line (table--buffer-substring-and-trim
3343 (table--goto-coordinate (cons from y))
3344 (table--goto-coordinate (cons to y)))))
3345 ;; escape special characters
3346 (with-temp-buffer
3347 (insert line)
3348 (goto-char (point-min))
3349 (while (re-search-forward "\\([#$~_^%{}]\\)\\|\\(\\\\\\)\\|\\([<>|]\\)" nil t)
3350 (if (match-beginning 1)
3351 (save-excursion
3352 (goto-char (match-beginning 1))
3353 (insert "\\"))
3354 (if (match-beginning 2)
3355 (replace-match "$\\backslash$" t t)
3356 (replace-match (concat "$" (match-string 3) "$")) t t)))
3357 (setq line (buffer-substring (point-min) (point-max))))
3358 ;; insert a column separator and column/multicolumn contents
3359 (with-current-buffer dest-buffer
3360 (unless first-p
3361 (insert (if (eq (char-before) ?\ ) "" " ") "& "))
3362 (if (> span 1)
3363 (insert (format "\\multicolumn{%d}{%sl|}{%s}" span (if first-p "|" "") line))
3364 (insert line)))
3365 (setq first-p nil)
3366 (setq span 1)
3367 (setq start (nth i col-list)))))))
3368 (setq start x0)
3369 (setq i 1)
3370 (while (setq c (nth i border-char-list))
3371 (if (eq c table-cell-vertical-char)
3372 (funcall insert-column start (1- (nth i col-list)))
3373 (setq span (1+ span)))
3374 (setq i (1+ i)))
3375 (funcall insert-column start x1))
3376 (with-current-buffer dest-buffer
3377 (insert (if (eq (char-before) ?\ ) "" " ") "\\\\\n"))))
3378 (setq y (1+ y)))
3379 (with-current-buffer dest-buffer
3380 (insert "\\hline\n"))
3381 ))
3382
3383;;;###autoload
3384(defun table-insert-sequence (str n increment interval justify)
3385 "Travel cells forward while inserting a specified sequence string in each cell.
3386STR is the base string from which the sequence starts. When STR is an
3387empty string then each cell content is erased. When STR ends with
3388numerical characters (they may optionally be surrounded by a pair of
3389parentheses) they are incremented as a decimal number. Otherwise the
3390last character in STR is incremented in ASCII code order. N is the
3391number of sequence elements to insert. When N is negative the cell
3392traveling direction is backward. When N is zero it travels forward
3393entire table. INCREMENT is the increment between adjacent sequence
3394elements and can be a negative number for effectively decrementing.
3395INTERVAL is the number of cells to travel between sequence element
3396insertion which is normally 1. When zero or less is given for
3397INTERVAL it is interpreted as number of cells per row so that sequence
3398is placed straight down vertically as long as the table's cell
3399structure is uniform. JUSTIFY is one of the symbol 'left, 'center or
3400'right, that specifies justification of the inserted string.
3401
3402Example:
3403
3404 (progn
3405 (table-insert 16 3 5 1)
3406 (table-forward-cell 15)
3407 (table-insert-sequence \"D0\" -16 1 1 'center)
3408 (table-forward-cell 16)
3409 (table-insert-sequence \"A[0]\" -16 1 1 'center)
3410 (table-forward-cell 1)
3411 (table-insert-sequence \"-\" 16 0 1 'center))
3412
3413 (progn
3414 (table-insert 16 8 5 1)
3415 (table-insert-sequence \"@\" 0 1 2 'right)
3416 (table-forward-cell 1)
3417 (table-insert-sequence \"64\" 0 1 2 'left))
3418"
3419 (interactive
3420 (progn
3421 (barf-if-buffer-read-only)
3422 (unless (table--probe-cell) (error "Table not found here"))
3423 (list (read-from-minibuffer
3424 "Sequence base string: " (car table-sequence-string-history) nil nil 'table-sequence-string-history)
3425 (string-to-number
3426 (table--read-from-minibuffer
3427 '("How many elements (0: maximum, negative: backward traveling)" . table-sequence-count-history)))
3428 (string-to-number
3429 (table--read-from-minibuffer
3430 '("Increment element by" . table-sequence-increment-history)))
3431 (string-to-number
3432 (table--read-from-minibuffer
3433 '("Cell interval (0: vertical, 1:horizontal)" . table-sequence-interval-history)))
3434 (let* ((completion-ignore-case t)
3435 (default (car table-sequence-justify-history)))
3436 (intern (downcase (completing-read
3437 (format "Justify (default %s): " default)
3438 '(("left") ("center") ("right"))
3439 nil t nil 'table-sequence-justify-history default)))))))
3440 (unless (or (interactive-p) (table--probe-cell)) (error "Table not found here"))
3441 (string-match "\\([0-9]*\\)\\([]})>]*\\)\\'" str)
3442 (if (interactive-p)
3443 (message "Sequencing..."))
3444 (let* ((prefix (substring str 0 (match-beginning 1)))
3445 (index (match-string 1 str))
3446 (fmt (format "%%%s%dd" (if (eq (string-to-char index) ?0) "0" "") (length index)))
3447 (postfix (match-string 2 str))
3448 (dim (table-query-dimension))
3449 (cells (nth 6 dim))
3450 (direction (if (< n 0) -1 1))
3451 (interval-count 0))
3452 (if (string= index "")
3453 (progn
3454 (setq index nil)
3455 (if (string= prefix "")
3456 (setq prefix nil)))
3457 (setq index (string-to-number index)))
3458 (if (< n 0) (setq n (- n)))
3459 (if (or (zerop n) (> n cells)) (setq n cells))
3460 (if (< interval 0) (setq interval (- interval)))
3461 (if (zerop interval) (setq interval (nth 4 dim)))
3462 (save-excursion
3463 (while (progn
3464 (if (> interval-count 0) nil
3465 (setq interval-count interval)
3466 (table-with-cache-buffer
3467 (goto-char (point-min))
3468 (if (not (or prefix index))
3469 (erase-buffer)
3470 (insert prefix)
3471 (if index (insert (format fmt index)))
3472 (insert postfix)
3473 (table--fill-region (point-min) (point) table-cell-info-width justify)
3474 (setq table-cell-info-justify justify))
3475 (setq table-inhibit-auto-fill-paragraph t))
3476 (table--update-cell 'now)
3477 (if index
3478 (setq index (+ index increment))
3479 (if (and prefix (string= postfix ""))
3480 (let ((len-1 (1- (length prefix))))
3481 (setq prefix (concat (substring prefix 0 len-1)
3482 (char-to-string
3483 (+ (string-to-char (substring prefix len-1)) increment)))))))
3484 (setq n (1- n)))
3485 (table-forward-cell direction t)
3486 (setq interval-count (1- interval-count))
3487 (setq cells (1- cells))
3488 (and (> n 0) (> cells 0)))))
3489 (table-recognize-cell 'force)
3490 (if (interactive-p)
3491 (message "Sequencing...done"))
3492 ))
3493
3494;;;###autoload
3495(defun table-delete-row (n)
3496 "Delete N row(s) of cells.
3497Delete N rows of cells from current row. The current row is the row
3498contains the current cell where point is located. Each row must
3499consists from cells of same height."
3500 (interactive "*p")
3501 (let ((orig-coord (table--get-coordinate))
3502 (bt-coord (table--get-coordinate (cdr (table--vertical-cell-list nil 'first-only))))
3503 lu-coord rb-coord rect)
3504 ;; determine the area to delete while testing row height uniformity
3505 (while (> n 0)
3506 (setq n (1- n))
3507 (unless (table--probe-cell)
3508 (error "Table not found"))
3509 (let ((cell-list (table--horizontal-cell-list 'left-to-right)))
3510 (unless
3511 (and (table--uniform-list-p
3512 (mapcar (lambda (cell) (cdr (table--get-coordinate (car cell)))) cell-list))
3513 (table--uniform-list-p
3514 (mapcar (lambda (cell) (cdr (table--get-coordinate (cdr cell)))) cell-list)))
3515 (error "Cells in this row are not in uniform height"))
3516 (unless lu-coord
3517 (setq lu-coord (table--get-coordinate (caar cell-list))))
3518 (setq rb-coord (table--get-coordinate (cdar (last cell-list))))
3519 (table--goto-coordinate (cons (car orig-coord) (+ 2 (cdr rb-coord))))))
3520 ;; copy the remaining area (below the deleting area)
3521 (setq rect (extract-rectangle
3522 (table--goto-coordinate (cons (1- (car lu-coord)) (1+ (cdr rb-coord))))
3523 (table--goto-coordinate (cons (1+ (car rb-coord)) (1+ (cdr bt-coord))))))
3524 ;; delete the deleting area and below together
3525 (delete-rectangle
3526 (table--goto-coordinate (cons (1- (car lu-coord)) (1- (cdr lu-coord))))
3527 (table--goto-coordinate (cons (1+ (car rb-coord)) (1+ (cdr bt-coord)))))
3528 (table--goto-coordinate (cons (1- (car lu-coord)) (1- (cdr lu-coord))))
3529 ;; insert the remaining area while appending blank lines below it
3530 (table--insert-rectangle
3531 (append rect (make-list (+ 2 (- (cdr rb-coord) (cdr lu-coord)))
3532 (make-string (+ 2 (- (car rb-coord) (car lu-coord))) ?\ ))))
3533 ;; remove the appended blank lines below the table if they are unnecessary
3534 (table--goto-coordinate (cons 0 (- (cdr bt-coord) (- (cdr rb-coord) (cdr lu-coord)))))
3535 (table--remove-blank-lines (+ 2 (- (cdr rb-coord) (cdr lu-coord))))
3536 ;; fix up intersections
3537 (let ((coord (cons (car lu-coord) (1- (cdr lu-coord))))
3538 (n (1+ (- (car rb-coord) (car lu-coord)))))
3539 (while (> n 0)
3540 (table--goto-coordinate coord)
3541 (if (save-excursion
3542 (or (and (table--goto-coordinate (cons (car coord) (1- (cdr coord))) 'no-extension)
3543 (looking-at (regexp-quote (char-to-string table-cell-vertical-char))))
3544 (and (table--goto-coordinate (cons (car coord) (1+ (cdr coord))) 'no-extension)
3545 (looking-at (regexp-quote (char-to-string table-cell-vertical-char))))))
3546 (progn
3547 (delete-char 1)
3548 (insert table-cell-intersection-char))
3549 (delete-char 1)
e99add21 3550 (insert (string-to-char table-cell-horizontal-chars)))
238240c9
RS
3551 (setq n (1- n))
3552 (setcar coord (1+ (car coord)))))
3553 ;; goto appropriate end point
3554 (table--goto-coordinate (cons (car orig-coord) (cdr lu-coord)))))
3555
3556;;;###autoload
3557(defun table-delete-column (n)
3558 "Delete N column(s) of cells.
3559Delete N columns of cells from current column. The current column is
3560the column contains the current cell where point is located. Each
3561column must consists from cells of same width."
3562 (interactive "*p")
3563 (let ((orig-coord (table--get-coordinate))
3564 lu-coord rb-coord)
3565 ;; determine the area to delete while testing column width uniformity
3566 (while (> n 0)
3567 (setq n (1- n))
3568 (unless (table--probe-cell)
3569 (error "Table not found"))
3570 (let ((cell-list (table--vertical-cell-list 'top-to-bottom)))
3571 (unless
3572 (and (table--uniform-list-p
3573 (mapcar (function (lambda (cell) (car (table--get-coordinate (car cell))))) cell-list))
3574 (table--uniform-list-p
3575 (mapcar (function (lambda (cell) (car (table--get-coordinate (cdr cell))))) cell-list)))
3576 (error "Cells in this column are not in uniform width"))
3577 (unless lu-coord
3578 (setq lu-coord (table--get-coordinate (caar cell-list))))
3579 (setq rb-coord (table--get-coordinate (cdar (last cell-list))))
3580 (table--goto-coordinate (cons (1+ (car rb-coord)) (cdr orig-coord)))))
3581 ;; delete the area
3582 (delete-rectangle
3583 (table--goto-coordinate (cons (car lu-coord) (1- (cdr lu-coord))))
3584 (table--goto-coordinate (cons (1+ (car rb-coord)) (1+ (cdr rb-coord)))))
3585 ;; fix up the intersections
3586 (let ((coord (cons (1- (car lu-coord)) (cdr lu-coord)))
3587 (n (1+ (- (cdr rb-coord) (cdr lu-coord)))))
3588 (while (> n 0)
3589 (table--goto-coordinate coord)
3590 (if (save-excursion
3591 (or (and (table--goto-coordinate (cons (1- (car coord)) (cdr coord)) 'no-extension)
e99add21
JB
3592 (looking-at (regexp-opt-charset
3593 (string-to-list table-cell-horizontal-chars))))
238240c9 3594 (and (table--goto-coordinate (cons (1+ (car coord)) (cdr coord)) 'no-extension)
e99add21
JB
3595 (looking-at (regexp-opt-charset
3596 (string-to-list table-cell-horizontal-chars))))))
238240c9
RS
3597 (progn
3598 (delete-char 1)
3599 (insert table-cell-intersection-char))
3600 (delete-char 1)
3601 (insert table-cell-vertical-char))
3602 (setq n (1- n))
3603 (setcdr coord (1+ (cdr coord)))))
3604 ;; goto appropriate end point
3605 (table--goto-coordinate (cons (car lu-coord) (cdr orig-coord)))))
3606
3607;;;###autoload
3608(defun table-capture (beg end &optional col-delim-regexp row-delim-regexp justify min-cell-width columns)
3609 "Convert plain text into a table by capturing the text in the region.
3610Create a table with the text in region as cell contents. BEG and END
3611specify the region. The text in the region is replaced with a table.
3612The removed text is inserted in the table. When optional
3613COL-DELIM-REGEXP and ROW-DELIM-REGEXP are provided the region contents
3614is parsed and separated into individual cell contents by using the
3615delimiter regular expressions. This parsing determines the number of
3616columns and rows of the table automatically. If COL-DELIM-REGEXP and
3617ROW-DELIM-REGEXP are omitted the result table has only one cell and
3618the entire region contents is placed in that cell. Optional JUSTIFY
3619is one of 'left, 'center or 'right, which specifies the cell
3620justification. Optional MIN-CELL-WIDTH specifies the minimum cell
3621width. Optional COLUMNS specify the number of columns when
3622ROW-DELIM-REGEXP is not specified.
3623
3624
3625Example 1:
3626
36271, 2, 3, 4
36285, 6, 7, 8
3629, 9, 10
3630
3631Running `table-capture' on above 3 line region with COL-DELIM-REGEXP
3632\",\" and ROW-DELIM-REGEXP \"\\n\" creates the following table. In
3633this example the cells are centered and minimum cell width is
3634specified as 5.
3635
3636+-----+-----+-----+-----+
3637| 1 | 2 | 3 | 4 |
3638+-----+-----+-----+-----+
3639| 5 | 6 | 7 | 8 |
3640+-----+-----+-----+-----+
3641| | 9 | 10 | |
3642+-----+-----+-----+-----+
3643
3644Note:
3645
3646In case the function is called interactively user must use \\[quoted-insert] `quoted-insert'
3647in order to enter \"\\n\" successfully. COL-DELIM-REGEXP at the end
3648of each row is optional.
3649
3650
3651Example 2:
3652
3653This example shows how a table can be used for text layout editing.
3654Let `table-capture' capture the following region starting from
3655-!- and ending at -*-, that contains three paragraphs and two item
3656name headers. This time specify empty string for both
3657COL-DELIM-REGEXP and ROW-DELIM-REGEXP.
3658
3659-!-`table-capture' is a powerful command however mastering its power
3660requires some practice. Here is a list of items what it can do.
3661
3662Parse Cell Items By using column delimiter regular
3663 expression and raw delimiter regular
3664 expression, it parses the specified text
3665 area and extracts cell items from
3666 non-table text and then forms a table out
3667 of them.
3668
3669Capture Text Area When no delimiters are specified it
3670 creates a single cell table. The text in
3671 the specified region is placed in that
3672 cell.-*-
3673
3674Now the entire content is captured in a cell which is itself a table
3675like this.
3676
3677+-----------------------------------------------------------------+
3678|`table-capture' is a powerful command however mastering its power|
3679|requires some practice. Here is a list of items what it can do. |
3680| |
3681|Parse Cell Items By using column delimiter regular |
3682| expression and raw delimiter regular |
3683| expression, it parses the specified text |
3684| area and extracts cell items from |
3685| non-table text and then forms a table out |
3686| of them. |
3687| |
3688|Capture Text Area When no delimiters are specified it |
3689| creates a single cell table. The text in |
3690| the specified region is placed in that |
3691| cell. |
3692+-----------------------------------------------------------------+
3693
3694By splitting the cell appropriately we now have a table consisting of
3695paragraphs occupying its own cell. Each cell can now be edited
3696independently.
3697
3698+-----------------------------------------------------------------+
3699|`table-capture' is a powerful command however mastering its power|
3700|requires some practice. Here is a list of items what it can do. |
3701+---------------------+-------------------------------------------+
3702|Parse Cell Items |By using column delimiter regular |
3703| |expression and raw delimiter regular |
3704| |expression, it parses the specified text |
3705| |area and extracts cell items from |
3706| |non-table text and then forms a table out |
3707| |of them. |
3708+---------------------+-------------------------------------------+
3709|Capture Text Area |When no delimiters are specified it |
3710| |creates a single cell table. The text in |
3711| |the specified region is placed in that |
3712| |cell. |
3713+---------------------+-------------------------------------------+
3714
3715By applying `table-release', which does the opposite process, the
3716contents become once again plain text. `table-release' works as
3717companion command to `table-capture' this way.
3718"
3719 (interactive
3720 (let ((col-delim-regexp)
3721 (row-delim-regexp))
3722 (barf-if-buffer-read-only)
3723 (if (table--probe-cell)
3724 (error "Can't insert a table inside a table"))
3725 (list
3726 (mark) (point)
3727 (setq col-delim-regexp
3728 (read-from-minibuffer "Column delimiter regexp: "
3729 (car table-col-delim-regexp-history) nil nil 'table-col-delim-regexp-history))
3730 (setq row-delim-regexp
3731 (read-from-minibuffer "Row delimiter regexp: "
3732 (car table-row-delim-regexp-history) nil nil 'table-row-delim-regexp-history))
3733 (let* ((completion-ignore-case t)
3734 (default (car table-capture-justify-history)))
3735 (if (and (string= col-delim-regexp "") (string= row-delim-regexp "")) 'left
3736 (intern
3737 (downcase (completing-read
3738 (format "Justify (default %s): " default)
3739 '(("left") ("center") ("right"))
3740 nil t nil 'table-capture-justify-history default)))))
3741 (if (and (string= col-delim-regexp "") (string= row-delim-regexp "")) "1"
3742 (table--read-from-minibuffer '("Minimum cell width" . table-capture-min-cell-width-history)))
3743 (if (and (not (string= col-delim-regexp "")) (string= row-delim-regexp ""))
3744 (string-to-number
3745 (table--read-from-minibuffer '("Number of columns" . 'table-capture-columns-history)))
3746 nil)
3747 )))
3748 (if (> beg end) (let ((tmp beg)) (setq beg end) (setq end tmp)))
3749 (if (string= col-delim-regexp "") (setq col-delim-regexp nil))
3750 (if (string= row-delim-regexp "") (setq row-delim-regexp nil))
3751 (if (and columns (< columns 1)) (setq columns nil))
3752 (unless min-cell-width (setq min-cell-width "5"))
3753 (let ((contents (buffer-substring beg end))
3754 (cols 0) (rows 0) c r cell-list
3755 (delim-pattern
3756 (if (and col-delim-regexp row-delim-regexp)
3757 (format "\\(\\(%s\\)?\\s *\\(%s\\)\\s *\\)\\|\\(\\(%s\\)\\s *\\)"
3758 col-delim-regexp row-delim-regexp col-delim-regexp)
3759 (if col-delim-regexp
3760 (format "\\(\\)\\(\\)\\(\\)\\(\\(%s\\)\\s *\\)" col-delim-regexp))))
3761 (contents-list))
3762 ;; when delimiters are specified extract cells and determine the cell dimension
3763 (if delim-pattern
3764 (with-temp-buffer
3765 (insert contents)
3766 ;; make sure the contents ends with a newline
3767 (goto-char (point-max))
3768 (unless (zerop (current-column))
3769 (insert ?\n))
3770 ;; skip the preceding white spaces
3771 (goto-char (point-min))
3772 (if (looking-at "\\s +")
3773 (goto-char (match-end 0)))
3774 ;; extract cell contents
3775 (let ((from (point)))
3776 (setq cell-list nil)
3777 (setq c 0)
3778 (while (and (re-search-forward delim-pattern nil t)
3779 (cond
3780 ;; row delimiter
3781 ((and (match-string 1) (not (string= (match-string 1) "")))
3782 (setq rows (1+ rows))
3783 (setq cell-list
3784 (append cell-list (list (buffer-substring from (match-beginning 1)))))
3785 (setq from (match-end 1))
3786 (setq contents-list
3787 (append contents-list (list cell-list)))
3788 (setq cell-list nil)
3789 (setq c (1+ c))
3790 (if (> c cols) (setq cols c))
3791 (setq c 0)
3792 t)
3793 ;; column delimiter
3794 ((and (match-string 4) (not (string= (match-string 4) "")))
3795 (setq cell-list
3796 (append cell-list (list (buffer-substring from (match-beginning 4)))))
3797 (setq from (match-end 4))
3798 (setq c (1+ c))
3799 (if (> c cols) (setq cols c))
3800 t)
3801 (t nil))))
3802 ;; take care of the last element without a post delimiter
3803 (unless (null (looking-at ".+$"))
3804 (setq cell-list
3805 (append cell-list (list (match-string 0))))
3806 (setq cols (1+ cols)))
3807 ;; take care of the last row without a terminating delimiter
3808 (unless (null cell-list)
3809 (setq rows (1+ rows))
3810 (setq contents-list
3811 (append contents-list (list cell-list)))))))
3812 ;; finalize the table dimension
3813 (if (and columns contents-list)
3814 ;; when number of columns are specified and cells are parsed determine the dimension
3815 (progn
3816 (setq cols columns)
3817 (setq rows (/ (+ (length (car contents-list)) columns -1) columns)))
3818 ;; when dimensions are not specified default to a single cell table
3819 (if (zerop rows) (setq rows 1))
3820 (if (zerop cols) (setq cols 1)))
3821 ;; delete the region and reform line breaks
3822 (delete-region beg end)
3823 (goto-char beg)
3824 (unless (zerop (current-column))
3825 (insert ?\n))
3826 (unless (looking-at "\\s *$")
3827 (save-excursion
3828 (insert ?\n)))
db95369b 3829 ;; insert the table
238240c9
RS
3830 ;; insert the cell contents
3831 (if (null contents-list)
3832 ;; single cell
3833 (let ((width) (height))
3834 (with-temp-buffer
3835 (insert contents)
3836 (table--remove-eol-spaces (point-min) (point-max))
3837 (table--untabify (point-min) (point-max))
3838 (setq width (table--measure-max-width))
3839 (setq height (1+ (table--current-line (point-max))))
3840 (setq contents (buffer-substring (point-min) (point-max))))
3841 (table-insert cols rows width height)
3842 (table-with-cache-buffer
3843 (insert contents)
3844 (setq table-inhibit-auto-fill-paragraph t)))
3845 ;; multi cells
3846 (table-insert cols rows min-cell-width 1)
3847 (setq r 0)
3848 (setq cell-list nil)
3849 (while (< r rows)
3850 (setq r (1+ r))
3851 (setq c 0)
3852 (unless cell-list
3853 (setq cell-list (car contents-list))
3854 (setq contents-list (cdr contents-list)))
3855 (while (< c cols)
3856 (setq c (1+ c))
3857 (if (car cell-list)
3858 (table-with-cache-buffer
3859 (insert (car cell-list))
3860 (setq cell-list (cdr cell-list))
3861 (setq table-cell-info-justify justify)))
3862 (table-forward-cell 1))))))
3863
3864;;;###autoload
3865(defun table-release ()
3866 "Convert a table into plain text by removing the frame from a table.
3867Remove the frame from a table and inactivate the table. This command
3868converts a table into plain text without frames. It is a companion to
3869`table-capture' which does the opposite process."
3870 (interactive)
3871 (let ((origin-cell (table--probe-cell))
3872 table-lu table-rb)
3873 (if origin-cell
3874 (let ((old-point (point-marker)))
3875 ;; save-excursion is not sufficient for this
3876 ;; because untabify operation moves point
3877 (set-marker-insertion-type old-point t)
3878 (unwind-protect
3879 (progn
3880 (while
3881 (progn
3882 (table-forward-cell 1 nil 'unrecognize)
3883 (let ((cell (table--probe-cell)))
3884 (if (or (null table-lu)
3885 (< (car cell) table-lu))
3886 (setq table-lu (car cell)))
3887 (if (or (null table-rb)
3888 (> (cdr cell) table-rb))
3889 (setq table-rb (cdr cell)))
3890 (and cell (not (equal cell origin-cell))))))
3891 (let* ((lu-coord (table--get-coordinate table-lu))
3892 (rb-coord (table--get-coordinate table-rb))
3893 (lu (table--goto-coordinate (table--offset-coordinate lu-coord '(-1 . -1)))))
3894 (table--spacify-frame)
3895 (setcdr rb-coord (1+ (cdr rb-coord)))
3896 (delete-rectangle lu (table--goto-coordinate (cons (car lu-coord) (cdr rb-coord))))
3897 (table--remove-eol-spaces
3898 (table--goto-coordinate (cons 0 (1- (cdr lu-coord))))
3899 (table--goto-coordinate rb-coord) nil t)))
3900 (goto-char old-point))))))
3901
3902;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3903;;
3904;; Worker functions (executed implicitly)
3905;;
3906
3907(defun table--make-cell-map ()
3908 "Make the table cell keymap if it does not exist yet."
3909 ;; this is irrelevant to keymap but good place to make sure to be executed
3910 (table--update-cell-face)
3911 (unless table-cell-map
3912 (let ((map (make-sparse-keymap))
3913 (remap-alist table-command-remap-alist))
3914 ;; table-command-prefix mode specific bindings
3915 (if (vectorp table-command-prefix)
3916 (mapcar (lambda (binding)
3917 (let ((seq (copy-sequence (car binding))))
3918 (and (vectorp seq)
3919 (listp (aref seq 0))
3920 (eq (car (aref seq 0)) 'control)
3921 (progn
3922 (aset seq 0 (cadr (aref seq 0)))
3923 (define-key map (vconcat table-command-prefix seq) (cdr binding))))))
3924 table-cell-bindings))
3925 ;; shorthand control bindings
3926 (mapcar (lambda (binding)
3927 (define-key map (car binding) (cdr binding)))
3928 table-cell-bindings)
3929 ;; remap normal commands to table specific version
3930 (while remap-alist
3931 (define-key map (vector 'remap (caar remap-alist)) (cdar remap-alist))
3932 (setq remap-alist (cdr remap-alist)))
3933 ;;
3934 (setq table-cell-map map)
3935 (fset 'table-cell-map map)))
3936 ;; add menu for table cells
3937 (unless table-disable-menu
3938 (easy-menu-define table-cell-menu-map table-cell-map "Table cell menu" table-cell-menu)
3939 (if (featurep 'xemacs)
3940 (easy-menu-add table-cell-menu)))
3941 (run-hooks 'table-cell-map-hook))
3942
3943;; Create the keymap after running the user init file so that the user
3944;; modification to the global-map is accounted.
3945(add-hook 'after-init-hook 'table--make-cell-map t)
3946
3947(defun *table--cell-self-insert-command ()
3948 "Table cell version of `self-insert-command'."
3949 (interactive "*")
3950 (let ((char (table--unibyte-char-to-multibyte last-command-char)))
3951 (if (eq buffer-undo-list t) nil
3952 (if (not (eq last-command this-command))
3953 (setq table-cell-self-insert-command-count 0)
3954 (if (car buffer-undo-list) nil
3955 (if (>= table-cell-self-insert-command-count 19)
3956 (setq table-cell-self-insert-command-count 0)
3957 (setq buffer-undo-list (cdr buffer-undo-list))
3958 (setq table-cell-self-insert-command-count (1+ table-cell-self-insert-command-count))))))
3959 (table--cell-insert-char char overwrite-mode)))
3960
3961(defun *table--cell-delete-backward-char (n)
3962 "Table cell version of `delete-backward-char'."
3963 (interactive "*p")
3964 (*table--cell-delete-char (- n)))
3965
3966(defun *table--cell-newline (&optional indent)
3967 "Table cell version of `newline'."
3968 (interactive "*")
3969 (table-with-cache-buffer
3970 (let ((column (current-column)))
3971 (insert ?\n)
3972 (if indent (indent-to-column column))
3973 ;; fill only when at the beginning of paragraph
3974 (if (= (point)
3975 (save-excursion
3976 (forward-paragraph -1)
3977 (if (looking-at "\\s *$")
3978 (forward-line 1))
3979 (point)))
3980 nil ; yes, at the beginning of the paragraph
3981 (setq table-inhibit-auto-fill-paragraph t)))))
3982
3983(defun *table--cell-open-line (n)
3984 "Table cell version of `open-line'."
3985 (interactive "*p")
3986 (table-with-cache-buffer
3987 (save-excursion
3988 (insert (make-string n ?\n))
3989 (table--fill-region (point) (point))
3990 (setq table-inhibit-auto-fill-paragraph t))))
3991
3992(defun *table--cell-newline-and-indent ()
3993 "Table cell version of `newline-and-indent'."
3994 (interactive)
3995 (*table--cell-newline t))
3996
3997(defun *table--cell-delete-char (n)
3998 "Table cell version of `delete-char'."
3999 (interactive "*p")
4000 (let ((overwrite overwrite-mode))
4001 (table-with-cache-buffer
4002 (if (and overwrite (< n 0))
4003 (progn
4004 (while (not (zerop n))
4005 (let ((coordinate (table--get-coordinate)))
4006 (if (zerop (car coordinate))
4007 (unless (zerop (cdr coordinate))
4008 (table--goto-coordinate (cons (1- table-cell-info-width) (1- (cdr coordinate))))
4009 (unless (eolp)
4010 (delete-char 1)))
4011 (delete-char -1)
4012 (insert ?\ )
4013 (forward-char -1)))
4014 (setq n (1+ n)))
4015 (setq table-inhibit-auto-fill-paragraph t))
4016 (let ((coordinate (table--get-coordinate))
4017 (end-marker (copy-marker (+ (point) n)))
4018 (deleted))
4019 (if (or (< end-marker (point-min))
4020 (> end-marker (point-max))) nil
4021 (table--remove-eol-spaces (point-min) (point-max))
4022 (setq deleted (buffer-substring (point) end-marker))
4023 (delete-char n)
4024 ;; in fixed width mode when two lines are concatenated
4025 ;; remove continuation character if there is one.
4026 (and table-fixed-width-mode
4027 (string-match "^\n" deleted)
4028 (equal (char-before) table-word-continuation-char)
4029 (delete-char -2))
4030 ;; see if the point is placed at the right tip of the previous
4031 ;; blank line, if so get rid of the preceding blanks.
4032 (if (and (not (bolp))
4033 (/= (cdr coordinate) (cdr (table--get-coordinate)))
4034 (let ((end (point)))
4035 (save-excursion
4036 (beginning-of-line)
4037 (re-search-forward "\\s +" end t)
4038 (= (point) end))))
4039 (replace-match ""))
4040 ;; do not fill the paragraph if the point is already at the end
4041 ;; of this paragraph and is following a blank character
4042 ;; (otherwise the filling squeezes the preceding blanks)
4043 (if (and (looking-at "\\s *$")
4044 (or (bobp)
4045 (save-excursion
4046 (backward-char)
4047 (looking-at "\\s "))))
4048 (setq table-inhibit-auto-fill-paragraph t))
4049 )
4050 (set-marker end-marker nil))))))
4051
4052(defun *table--cell-quoted-insert (arg)
4053 "Table cell version of `quoted-insert'."
4054 (interactive "*p")
4055 (let ((char (table--unibyte-char-to-multibyte (read-quoted-char))))
4056 (while (> arg 0)
4057 (table--cell-insert-char char nil)
4058 (setq arg (1- arg)))))
4059
4060(defun *table--cell-describe-mode ()
4061 "Table cell version of `describe-mode'."
4062 (interactive)
4063 (if (not (table--point-in-cell-p))
4064 (call-interactively 'describe-mode)
4065 (with-output-to-temp-buffer "*Help*"
4066 (princ "Table mode: (in ")
4067 (princ mode-name)
4068 (princ " mode)
4069
4070Table is not a mode technically. You can regard it as a pseudo mode
4071which exists locally within a buffer. It overrides some standard
4072editing behaviors. Editing operations in a table produces confined
4073effects to the current cell. It may grow the cell horizontally and/or
4074vertically depending on the newly entered or deleted contents of the
4075cell, and also depending on the current mode of cell.
4076
4077In the normal mode the table preserves word continuity. Which means
4078that a word never gets folded into multiple lines. For this purpose
4079table will occasionally grow the cell width. On the other hand, when
4080in a fixed width mode all cell width are fixed. When a word can not
4081fit in the cell width the word is folded into the next line. The
4082folded location is marked by a continuation character which is
4083specified in the variable `table-word-continuation-char'.
4084")
4085 (print-help-return-message))))
4086
4087(defun *table--cell-describe-bindings ()
4088 "Table cell version of `describe-bindings'."
4089 (interactive)
4090 (if (not (table--point-in-cell-p))
4091 (call-interactively 'describe-bindings)
4092 (with-output-to-temp-buffer "*Help*"
4093 (princ "Table Bindings:
4094key binding
4095--- -------
4096
4097")
4098 (mapcar (lambda (binding)
4099 (princ (format "%-16s%s\n"
4100 (key-description (car binding))
4101 (cdr binding))))
4102 table-cell-bindings)
4103 (print-help-return-message))))
4104
4105(defun *table--cell-dabbrev-expand (arg)
4106 "Table cell version of `dabbrev-expand'."
4107 (interactive "*P")
4108 (let ((dabbrev-abbrev-char-regexp (concat "[^"
4109 (char-to-string table-cell-vertical-char)
4110 (char-to-string table-cell-intersection-char)
4111 " \n]")))
4112 (table-with-cache-buffer
4113 (dabbrev-expand arg))))
4114
4115(defun *table--cell-dabbrev-completion (&optional arg)
4116 "Table cell version of `dabbrev-completion'."
4117 (interactive "*P")
4118 (error "`dabbrev-completion' is incompatible with table")
4119 (let ((dabbrev-abbrev-char-regexp (concat "[^"
4120 (char-to-string table-cell-vertical-char)
4121 (char-to-string table-cell-intersection-char)
4122 " \n]")))
4123 (table-with-cache-buffer
4124 (dabbrev-completion arg))))
4125
4126(defun *table--present-cell-popup-menu (event)
4127 "Present and handle cell popup menu."
4128 (interactive "e")
4129 (unless table-disable-menu
4130 (select-window (posn-window (event-start event)))
4131 (goto-char (posn-point (event-start event)))
4132 (let ((item-list (x-popup-menu event table-cell-menu-map))
4133 (func table-cell-menu-map))
4134 (while item-list
4135 (setq func (nth 3 (assoc (car item-list) func)))
4136 (setq item-list (cdr item-list)))
4137 (if (and (symbolp func) (fboundp func))
4138 (call-interactively func)))))
4139
4140;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4141;;
4142;; Cell updating functions
4143;;
4144
4145(defun table--update-cell (&optional now)
4146 "Update the table cell contents.
4147When the optional parameter NOW is nil it only sets up the update
4148timer. If it is non-nil the function copies the contents of the cell
4149cache buffer into the designated cell in the table buffer."
4150 (if (null table-update-timer) nil
4151 (table--cancel-timer table-update-timer)
4152 (setq table-update-timer nil))
4153 (if (or (not now)
4154 (and (boundp 'quail-converting)
4155 quail-converting) ;; defer operation while current quail work is not finished.
4156 (and (boundp 'quail-translating)
4157 quail-translating))
4158 (setq table-update-timer
4159 (table--set-timer table-time-before-update
4160 (function table--update-cell)
4161 'now))
4162 (save-current-buffer
4163 (set-buffer table-cell-buffer)
4164 (let ((cache-buffer (get-buffer-create table-cache-buffer-name))
4165 (org-coord (table--get-coordinate))
4166 (in-cell (equal (table--cell-to-coord (table--probe-cell))
4167 (cons table-cell-info-lu-coordinate table-cell-info-rb-coordinate)))
4168 rectangle)
4169 (set-buffer cache-buffer)
4170 (setq rectangle
4171 (extract-rectangle
4172 1
4173 (table--goto-coordinate (cons table-cell-info-width (1- table-cell-info-height)))))
4174 (set-buffer table-cell-buffer)
4175 (delete-rectangle (table--goto-coordinate table-cell-info-lu-coordinate)
4176 (table--goto-coordinate table-cell-info-rb-coordinate))
4177 (table--goto-coordinate table-cell-info-lu-coordinate)
4178 (table--insert-rectangle rectangle)
4179 (let* ((cell (table--probe-cell))) ; must probe again in case of wide characters
4180 (table--put-cell-property cell)
4181 (table--put-cell-justify-property cell table-cell-info-justify)
4182 (table--put-cell-valign-property cell table-cell-info-valign))
4183 (table--goto-coordinate
4184 (if in-cell
4185 (table--transcoord-cache-to-table table-cell-cache-point-coordinate)
4186 org-coord))))
4187 ;; simulate undo behavior under overwrite-mode
4188 (if (and overwrite-mode (not (eq buffer-undo-list t)))
4189 (setq buffer-undo-list (cons nil buffer-undo-list)))))
4190
4191(defun table--update-cell-widened (&optional now)
4192 "Update the contents of the cells that are affected by widening operation."
4193 (if (null table-widen-timer) nil
4194 (table--cancel-timer table-widen-timer)
4195 (setq table-widen-timer nil))
4196 (if (not now)
4197 (setq table-widen-timer
4198 (table--set-timer (+ table-time-before-update table-time-before-reformat)
4199 (function table--update-cell-widened)
4200 'now))
4201 (save-current-buffer
4202 (if table-update-timer
4203 (table--update-cell 'now))
4204 (set-buffer table-cell-buffer)
4205 (let* ((current-coordinate (table--get-coordinate))
4206 (current-cell-coordinate (table--cell-to-coord (table--probe-cell)))
4207 (cell-coord-list (progn
4208 (table--goto-coordinate table-cell-info-lu-coordinate)
4209 (table--cell-list-to-coord-list (table--vertical-cell-list)))))
4210 (while cell-coord-list
4211 (let* ((cell-coord (prog1 (car cell-coord-list) (setq cell-coord-list (cdr cell-coord-list))))
4212 (currentp (equal cell-coord current-cell-coordinate)))
4213 (if currentp (table--goto-coordinate current-coordinate)
4214 (table--goto-coordinate (car cell-coord)))
4215 (table-recognize-cell 'froce)
4216 (let ((table-inhibit-update t))
4217 (table-with-cache-buffer
4218 (let ((sticky (and currentp
4219 (save-excursion
4220 (unless (bolp) (forward-char -1))
4221 (looking-at ".*\\S ")))))
4222 (table--fill-region (point-min) (point-max))
4223 (if sticky
4224 (setq current-coordinate (table--transcoord-cache-to-table))))))
4225 (table--update-cell 'now)
4226 ))
4227 (table--goto-coordinate current-coordinate)
4228 (table-recognize-cell 'froce)))))
4229
4230(defun table--update-cell-heightened (&optional now)
4231 "Update the contents of the cells that are affected by heightening operation."
4232 (if (null table-heighten-timer) nil
4233 (table--cancel-timer table-heighten-timer)
4234 (setq table-heighten-timer nil))
4235 (if (not now)
4236 (setq table-heighten-timer
4237 (table--set-timer (+ table-time-before-update table-time-before-reformat)
4238 (function table--update-cell-heightened)
4239 'now))
4240 (save-current-buffer
4241 (if table-update-timer
4242 (table--update-cell 'now))
4243 (if table-widen-timer
4244 (table--update-cell-widened 'now))
4245 (set-buffer table-cell-buffer)
4246 (let* ((current-coordinate (table--get-coordinate))
4247 (current-cell-coordinate (table--cell-to-coord (table--probe-cell)))
4248 (cell-coord-list (progn
4249 (table--goto-coordinate table-cell-info-lu-coordinate)
4250 (table--cell-list-to-coord-list (table--horizontal-cell-list)))))
4251 (while cell-coord-list
4252 (let* ((cell-coord (prog1 (car cell-coord-list) (setq cell-coord-list (cdr cell-coord-list))))
4253 (currentp (equal cell-coord current-cell-coordinate)))
4254 (if currentp (table--goto-coordinate current-coordinate)
4255 (table--goto-coordinate (car cell-coord)))
4256 (table-recognize-cell 'froce)
4257 (let ((table-inhibit-update t))
4258 (table-with-cache-buffer
4259 (let ((sticky (and currentp
4260 (save-excursion
4261 (unless (bolp) (forward-char -1))
4262 (looking-at ".*\\S ")))))
4263 (table--valign)
4264 (if sticky
4265 (setq current-coordinate (table--transcoord-cache-to-table))))))
4266 (table--update-cell 'now)
4267 ))
4268 (table--goto-coordinate current-coordinate)
4269 (table-recognize-cell 'froce)))))
4270
4271;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4272;;
4273;; Service functions (for external packages)
4274;;
4275
4276(defun table-goto-top-left-corner ()
4277 "Move point to top left corner of the current table and return the char position."
4278 (table--goto-coordinate
4279 (cons
4280 (1- (car (table--get-coordinate (car (table--horizontal-cell-list t t)))))
4281 (1- (cdr (table--get-coordinate (car (table--vertical-cell-list t t))))))))
4282
4283(defun table-goto-top-right-corner ()
4284 "Move point to top right corner of the current table and return the char position."
4285 (table--goto-coordinate
4286 (cons
4287 (car (table--get-coordinate (cdr (table--horizontal-cell-list nil t))))
4288 (1- (cdr (table--get-coordinate (car (table--vertical-cell-list t t))))))))
4289
4290(defun table-goto-bottom-left-corner ()
4291 "Move point to bottom left corner of the current table and return the char position."
4292 (table--goto-coordinate
4293 (cons
4294 (1- (car (table--get-coordinate (car (table--horizontal-cell-list t t)))))
4295 (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))))
4296
4297(defun table-goto-bottom-right-corner ()
4298 "Move point to bottom right corner of the current table and return the char position."
4299 (table--goto-coordinate
4300 (cons
4301 (car (table--get-coordinate (cdr (table--horizontal-cell-list nil t))))
4302 (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))))
4303
4304(defun table-call-interactively (function &optional recoard-flag keys)
4305 "Call FUNCTION, or a table version of it if applicable.
4306See `call-interactively' for full description of the arguments."
4307 (let ((table-func (intern-soft (format "*table--cell-%s" function))))
4308 (call-interactively
4309 (if (and table-func
4310 (table--point-in-cell-p))
4311 table-func
4312 function) recoard-flag keys)))
4313
4314(defun table-funcall (function &rest arguments)
4315 "Call FUNCTION, or a table version of it if applicable.
4316See `funcall' for full description of the arguments."
4317 (let ((table-func (intern-soft (format "*table--cell-%s" function))))
4318 (apply
4319 (if (and table-func
4320 (table--point-in-cell-p))
4321 table-func
4322 function)
4323 arguments)))
4324
4325(defmacro table-apply (function &rest arguments)
4326 "Call FUNCTION, or a table version of it if applicable.
4327See `apply' for full description of the arguments."
4328 (let ((table-func (make-symbol "table-func")))
4329 `(let ((,table-func (intern-soft (format "*table--cell-%s" ,function))))
4330 (apply
4331 (if (and ,table-func
4332 (table--point-in-cell-p))
4333 ,table-func
4334 ,function)
4335 ,@arguments))))
4336
4337;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4338;;
4339;; Utility functions
4340;;
4341
4342(defun table--read-from-minibuffer (prompt-history)
4343 "A wrapper to `read-from-minibuffer'.
4344PROMPT-HISTORY is a cons cell which car is the prompt string and the
4345cdr is the history symbol."
4346 (let ((default (car (symbol-value (cdr prompt-history)))))
4347 (read-from-minibuffer
4348 (format "%s (default %s): " (car prompt-history) default)
4349 "" nil nil (cdr prompt-history) default))
4350 (and (featurep 'xemacs)
4351 (equal (car (symbol-value (cdr prompt-history))) "")
4352 (set (cdr prompt-history)
4353 (cdr (symbol-value (cdr prompt-history)))))
4354 (car (symbol-value (cdr prompt-history))))
4355
4356(defun table--unibyte-char-to-multibyte (char)
4357 "Convert CHAR by `unibyte-char-to-multibyte' when possible and necessary."
4358 ;; This part is take from `quoted-insert'.
4359 ;; Assume character codes 0240 - 0377 stand for characters in some
4360 ;; single-byte character set, and convert them to Emacs
4361 ;; characters.
4362 (if (and enable-multibyte-characters
4363 (fboundp 'unibyte-char-to-multibyte)
4364 (>= char ?\240)
4365 (<= char ?\377))
4366 (unibyte-char-to-multibyte char)
4367 char))
4368
4369(defun table--buffer-substring-and-trim (beg end)
4370 "Extract buffer substring and remove blanks from front and the rear of it."
4371 (save-excursion
4372 (save-restriction
4373 (narrow-to-region (goto-char beg) end)
4374 (if (re-search-forward "\\s *")
4375 (setq beg (match-end 0)))
4376 (if (re-search-forward "\\s *\\'" end t)
4377 (setq end (match-beginning 0)))
4378 (table--remove-cell-properties
4379 0 (- end beg)
4380 (buffer-substring beg end)))))
4381
4382(defun table--valign ()
4383 "Vertically align the cache cell contents.
4384Current buffer must be the cache buffer at the entry to this function.
4385Returns the coordinate of the final point location."
4386 (if (or (null table-cell-info-valign)
4387 (eq table-cell-info-valign 'none))
4388 (table--get-coordinate)
4389 (let ((saved-point (point-marker)))
4390 ;;(set-marker-insertion-type saved-point t)
4391 (goto-char (point-min))
4392 (let* ((from (and (re-search-forward "^.*\\S " nil t)
4393 (table--current-line)))
4394 (to (let ((tmp from))
4395 (while (re-search-forward "^.*\\S " nil t)
4396 (setq tmp (table--current-line)))
4397 tmp))
4398 (content-height (and from to (1+ (- to from)))))
4399 (unless (null content-height)
4400 (goto-char (point-min))
4401 (if (looking-at "\\s *\n")
4402 (replace-match ""))
4403 (cond ((eq table-cell-info-valign 'middle)
4404 (insert (make-string (/ (- table-cell-info-height content-height) 2) ?\n)))
4405 ((eq table-cell-info-valign 'bottom)
4406 (insert (make-string (- table-cell-info-height content-height) ?\n))))
4407 (table--goto-coordinate (cons table-cell-info-width (1- table-cell-info-height)))
4408 (if (re-search-forward "\\s +\\'" nil t)
4409 (replace-match ""))))
4410 (goto-char saved-point)
4411 (set-marker saved-point nil)
4412 (let ((coord (table--get-coordinate)))
4413 (unless (< (cdr coord) table-cell-info-height)
4414 (setcdr coord (1- table-cell-info-height))
4415 (table--goto-coordinate coord))
4416 coord))))
4417
4418(defun table--query-justification ()
4419 (barf-if-buffer-read-only)
4420 (let* ((completion-ignore-case t)
4421 (default (car table-justify-history)))
4422 (intern (downcase (completing-read
4423 (format "Justify (default %s): " default)
4424 '(("left") ("center") ("right") ("top") ("middle") ("bottom") ("none"))
4425 nil t nil 'table-justify-history default)))))
4426
4427(defun table--spacify-frame ()
4428 "Spacify table frame.
4429Replace frame characters with spaces."
e99add21
JB
4430 (let ((frame-char
4431 (append (string-to-list table-cell-horizontal-chars)
4432 (list table-cell-intersection-char table-cell-vertical-char))))
238240c9
RS
4433 (while
4434 (progn
4435 (cond
4436 ((eq (char-after) table-cell-intersection-char)
4437 (save-excursion
4438 (let ((col (current-column)))
4439 (and (zerop (forward-line 1))
4440 (zerop (current-column))
4441 (move-to-column col)
4442 (table--spacify-frame))))
4443 (delete-char 1)
4444 (insert-before-markers ?\ ))
e99add21 4445 ((table--cell-horizontal-char-p (char-after))
238240c9
RS
4446 (while (progn
4447 (delete-char 1)
4448 (insert-before-markers ?\ )
e99add21 4449 (table--cell-horizontal-char-p (char-after)))))
238240c9
RS
4450 ((eq (char-after) table-cell-vertical-char)
4451 (while (let ((col (current-column)))
4452 (delete-char 1)
4453 (insert-before-markers ?\ )
4454 (and (zerop (forward-line 1))
4455 (zerop (current-column))
4456 (move-to-column col)
4457 (eq (char-after) table-cell-vertical-char))))))
4458 (memq (char-after) frame-char)))))
4459
4460(defun table--remove-blank-lines (n)
4461 "Delete N blank lines from the current line.
4462For adjusting below area of the table when the table is shortened."
4463 (move-to-column 0)
4464 (let ((first-blank t))
4465 (while (> n 0)
4466 (setq n (1- n))
4467 (cond ((looking-at "\\s *\\'")
4468 (delete-region (match-beginning 0) (match-end 0))
4469 (setq n 0))
4470 ((and (looking-at "\\([ \t]*\n[ \t]*\\)\n") first-blank)
4471 (delete-region (match-beginning 1) (match-end 1)))
4472 ((looking-at "[ \t]*$")
4473 (delete-region (match-beginning 0) (match-end 0))
4474 (forward-line 1))
4475 (t
4476 (setq first-blank nil)
4477 (forward-line 1))))))
4478
4479(defun table--uniform-list-p (l)
4480 "Return nil when LIST contains non equal elements. Otherwise return t."
4481 (if (null l) t
4482 (catch 'end
4483 (while (cdr l)
4484 (if (not (equal (car l) (cadr l))) (throw 'end nil))
4485 (setq l (cdr l)))
4486 t)))
4487
4488(defun table--detect-cell-alignment (cell)
4489 "Detect CELL contents alignment.
4490Guess CELL contents alignment both horizontally and vertically by
4491looking at the appearance of the CELL contents."
4492 (let ((cell-contents (extract-rectangle (car cell) (cdr cell)))
4493 (left-margin 0)
4494 (right-margin 0)
4495 (top-margin 0)
4496 (bottom-margin 0)
4497 (margin-diff 0)
4498 (margin-info-available nil)
4499 justify valign)
4500 (with-temp-buffer
4501 (table--insert-rectangle cell-contents)
4502 ;; determine the horizontal justification
4503 (goto-char (point-min))
4504 (while (re-search-forward "^\\( *\\).*[^ \n]\\( *\\)$" nil t)
4505 (setq margin-info-available t)
4506 (let* ((lm (- (match-end 1) (match-beginning 1)))
4507 (rm (- (match-end 2) (match-beginning 2)))
4508 (md (abs (- lm rm))))
4509 (if (> lm left-margin)
4510 (setq left-margin lm))
4511 (if (> rm right-margin)
4512 (setq right-margin rm))
4513 (if (> md margin-diff)
4514 (setq margin-diff md))))
4515 (setq justify
4516 (cond
4517 ((and margin-info-available
4518 (<= margin-diff 1)
4519 (> left-margin 0)) 'center)
4520 ((and margin-info-available
4521 (zerop right-margin)
4522 (> left-margin 0)) 'right)
4523 (t 'left)))
4524 ;; determine the vertical justification
4525 (goto-char (point-min))
4526 (if (and (re-search-forward "\\s *\\S " nil t)
4527 (/= (match-beginning 0) (match-end 0)))
4528 (setq top-margin (1- (count-lines (match-beginning 0) (match-end 0)))))
4529 (if (and (re-search-forward "\\s *\\'" nil t)
4530 (/= (match-beginning 0) (match-end 0)))
4531 (setq bottom-margin (1- (count-lines (match-beginning 0) (match-end 0)))))
4532 (setq valign
4533 (cond
4534 ((and (> top-margin 0)
4535 (> bottom-margin 0)
4536 (<= (abs (- top-margin bottom-margin)) 1)) 'middle)
4537 ((and (> top-margin 0)
4538 (zerop bottom-margin)) 'bottom)
4539 (t nil))))
4540 (table--put-cell-justify-property cell justify)
4541 (table--put-cell-valign-property cell valign)))
4542
4543(defun table--string-to-number-list (str)
4544 "Return a list of numbers in STR."
4545 (let ((idx 0)
4546 (nl nil))
4547 (while (string-match "[-0-9.]+" str idx)
4548 (setq idx (match-end 0))
4549 (setq nl (cons (string-to-number (match-string 0 str)) nl)))
4550 (nreverse nl)))
4551
4552(defun table--justify-cell-contents (justify &optional paragraph)
4553 "Justify the current cell contents.
4554JUSTIFY is a symbol 'left, 'center or 'right for horizontal, or 'top,
4555'middle, 'bottom or 'none for vertical. When PARAGRAPH is non-nil the
4556justify operation is limited to the current paragraph."
4557 (table-with-cache-buffer
4558 (let ((beg (point-min))
4559 (end (point-max-marker))
4560 (fill-column table-cell-info-width)
4561 (adaptive-fill-mode nil)
4562 (valign-symbols '(top middle bottom none)))
4563 (unless paragraph
4564 (if (memq justify valign-symbols)
4565 (setq table-cell-info-valign
4566 (if (eq justify 'none) nil justify))
4567 (setq table-cell-info-justify justify)))
4568 (save-excursion
4569 (if paragraph
4570 (let ((paragraph-start "\n"))
4571 (forward-paragraph)
4572 (or (bolp) (newline 1))
4573 (set-marker end (point))
4574 (setq beg (progn (forward-paragraph -1) (point)))))
4575 (if (memq justify valign-symbols)
4576 (table--valign)
4577 (table--remove-eol-spaces beg end 'bol)
4578 (let ((paragraph-start table-paragraph-start))
4579 (fill-region beg end table-cell-info-justify))))
4580 (setq table-inhibit-auto-fill-paragraph t)
4581 (set-marker end nil)))
4582 (table--update-cell 'now))
4583
4584(defun table--horizontally-shift-above-and-below (columns-to-extend top-to-bottom-coord-list)
4585 "Horizontally shift outside contents right above and right below of the table.
4586This function moves the surrounding text outside of the table so that
4587they match the horizontal growth/shrink of the table. It also
4588untabify the shift affected area including the right side of the table
4589so that tab related uneven shifting is avoided. COLUMNS-TO-EXTEND
4590specifies the number of columns the table grows, or shrinks if
4591negative. TOP-TO-BOTTOM-COORD-LIST is the vertical cell coordinate
4592list. This list can be any vertical list within the table."
4593 (save-excursion
4594 (let (beg-coord end-coord)
4595 (table--goto-coordinate (caar top-to-bottom-coord-list))
4596 (let* ((cell (table--horizontal-cell-list nil 'first-only 'top))
4597 (coord (cons (car (table--get-coordinate (cdr cell)))
4598 (cdr (table--get-coordinate (car cell))))))
4599 (setcar coord (1+ (car coord)))
4600 (setcdr coord (- (cdr coord) 2))
4601 (setq beg-coord (cons (car coord) (1+ (cdr coord))))
4602 (while (and (table--goto-coordinate coord 'no-extension)
4603 (not (looking-at "\\s *$")))
4604 (if (< columns-to-extend 0)
4605 (progn
4606 (table--untabify-line)
4607 (delete-char columns-to-extend))
4608 (table--untabify-line (point))
4609 (insert (make-string columns-to-extend ?\ )))
4610 (setcdr coord (1- (cdr coord)))))
4611 (table--goto-coordinate (caar (last top-to-bottom-coord-list)))
4612 (let ((coord (table--get-coordinate (cdr (table--horizontal-cell-list nil 'first-only 'bottom)))))
4613 (setcar coord (1+ (car coord)))
4614 (setcdr coord (+ (cdr coord) 2))
4615 (setq end-coord (cons (car coord) (1- (cdr coord))))
4616 (while (and (table--goto-coordinate coord 'no-extension)
4617 (not (looking-at "\\s *$")))
4618 (if (< columns-to-extend 0)
4619 (progn
4620 (table--untabify-line)
4621 (delete-char columns-to-extend))
4622 (table--untabify-line (point))
4623 (insert (make-string columns-to-extend ?\ )))
4624 (setcdr coord (1+ (cdr coord)))))
4625 (while (<= (cdr beg-coord) (cdr end-coord))
4626 (table--untabify-line (table--goto-coordinate beg-coord 'no-extension))
4627 (setcdr beg-coord (1+ (cdr beg-coord)))))))
4628
4629(defun table--create-growing-space-below (lines-to-extend left-to-right-coord-list bottom-border-y)
4630 "Create growing space below the table.
4631This function creates growing space below the table slightly
4632intelligent fashion. Following is the cases it handles for each
4633growing line:
4634 1. When the first line below the table is a complete blank line it
4635inserts a blank line.
4636 2. When the line starts with a prefix that matches the prefix of the
4637bottom line of the table it inserts a line consisting of prefix alone.
4638 3. Otherwise it deletes the rectangular contents where table will
4639grow into."
4640 (save-excursion
4641 (let ((i 0)
4642 (prefix (and (table--goto-coordinate (cons 0 bottom-border-y))
4643 (re-search-forward
4644 ".*\\S "
4645 (save-excursion
4646 (table--goto-coordinate
4647 (cons (1- (caar (car left-to-right-coord-list))) bottom-border-y)))
4648 t)
4649 (buffer-substring (match-beginning 0) (match-end 0)))))
4650 (while (< i lines-to-extend)
4651 (let ((y (+ i bottom-border-y 1)))
4652 (table--goto-coordinate (cons 0 y))
4653 (cond
4654 ((looking-at "\\s *$")
4655 (insert ?\n))
4656 ((and prefix (looking-at (concat (regexp-quote prefix) "\\s *$")))
4657 (insert prefix ?\n))
4658 (t
4659 (delete-rectangle
4660 (table--goto-coordinate (cons (1- (caar (car left-to-right-coord-list))) y))
4661 (table--goto-coordinate (cons (1+ (cadr (car (last left-to-right-coord-list)))) y))))))
4662 (setq i (1+ i))))))
4663
4664(defun table--untabify-line (&optional from)
4665 "Untabify current line.
4666Unlike save-excursion this guarantees preserving the cursor location
4667even when the point is on a tab character which is to be removed.
4668Optional FROM narrows the subject operation from this point to the end
4669of line."
4670 (let ((current-coordinate (table--get-coordinate)))
4671 (table--untabify (or from (progn (beginning-of-line) (point)))
4672 (progn (end-of-line) (point)))
4673 (table--goto-coordinate current-coordinate)))
4674
4675(defun table--untabify (beg end)
4676 "Wrapper to raw untabify."
4677 (untabify beg end)
4678 (if (featurep 'xemacs)
4679 ;; Cancel strange behavior of xemacs
4680 (message "")))
4681
4682(defun table--multiply-string (string multiplier)
4683 "Multiply string and return it."
4684 (let ((ret-str ""))
4685 (while (> multiplier 0)
4686 (setq ret-str (concat ret-str string))
4687 (setq multiplier (1- multiplier)))
4688 ret-str))
4689
951f97e6
SM
4690(defun table--line-column-position (line column)
4691 "Return the location of LINE forward at COLUMN."
4692 (save-excursion
4693 (forward-line line)
4694 (move-to-column column)
4695 (point)))
4696
4697(defun table--row-column-insertion-point-p (&optional columnp)
4698 "Return non nil if it makes sense to insert a row or a column at point."
4699 (and (not buffer-read-only)
4700 (or (get-text-property (point) 'table-cell)
4701 (let ((column (current-column)))
4702 (if columnp
4703 (or (text-property-any (line-beginning-position 0)
4704 (table--line-column-position -1 column)
4705 'table-cell t)
4706 (text-property-any (line-beginning-position) (point) 'table-cell t)
4707 (text-property-any (line-beginning-position 2)
4708 (table--line-column-position 1 column)
4709 'table-cell t))
4710 (text-property-any (table--line-column-position -2 column)
4711 (table--line-column-position -2 (+ 2 column))
4712 'table-cell t))))))
4713
238240c9
RS
4714(defun table--find-row-column (&optional columnp no-error)
4715 "Search table and return a cell coordinate list of row or column."
4716 (let ((current-coordinate (table--get-coordinate)))
4717 (catch 'end
4718 (catch 'error
4719 (let ((coord (table--get-coordinate)))
4720 (while
4721 (progn
4722 (if columnp (setcar coord (1- (car coord)))
4723 (setcdr coord (1- (cdr coord))))
4724 (>= (if columnp (car coord) (cdr coord)) 0))
4725 (while (progn
4726 (table--goto-coordinate coord 'no-extension 'no-tab-expansion)
e99add21
JB
4727 (not (looking-at (format "[%s%c%c]"
4728 table-cell-horizontal-chars
238240c9
RS
4729 table-cell-vertical-char
4730 table-cell-intersection-char))))
4731 (if columnp (setcar coord (1- (car coord)))
4732 (setcdr coord (1- (cdr coord))))
4733 (if (< (if columnp (car coord) (cdr coord)) 0)
4734 (throw 'error nil)))
4735 (if (table--probe-cell)
4736 (throw 'end (table--cell-list-to-coord-list (if columnp
4737 (table--vertical-cell-list t nil 'left)
4738 (table--horizontal-cell-list t nil 'top))))
4739 (table--goto-coordinate (table--offset-coordinate coord (if columnp '(0 . 1) '(1 . 0)))
4740 'no-extension 'no-tab-expansion)
4741 (if (table--probe-cell)
4742 (throw 'end (table--cell-list-to-coord-list (if columnp
4743 (table--vertical-cell-list t nil 'left)
4744 (table--horizontal-cell-list t nil 'top)))))))))
4745 (table--goto-coordinate current-coordinate)
4746 (if no-error nil
4747 (error "Table not found")))))
4748
4749(defun table--min-coord-list (coord-list)
4750 "Return minimum cell dimension of COORD-LIST.
4751COORD-LIST is a list of coordinate pairs (lu-coord . rb-coord), where
4752each pair in the list represents a cell. lu-coord is the left upper
4753coordinate of a cell and rb-coord is the right bottom coordinate of a
4754cell. A coordinate is a pair of x and y axis coordinate values. The
4755return value is a cons cell (min-w . min-h), where min-w and min-h are
4756respectively the minimum width and the minimum height of all the cells
4757in the list."
4758 (if (null coord-list) nil
4759 (let ((min-width 134217727)
4760 (min-height 134217727))
4761 (while coord-list
4762 (let* ((coord (prog1 (car coord-list) (setq coord-list (cdr coord-list))))
4763 (width (- (cadr coord) (caar coord)))
4764 (height (1+ (- (cddr coord) (cdar coord)))))
4765 (if (< width min-width) (setq min-width width))
4766 (if (< height min-height) (setq min-height height))))
4767 (cons min-width min-height))))
4768
4769(defun table--cell-can-split-horizontally-p ()
4770 "Test if a cell can split at current location horizontally."
4771 (and (not buffer-read-only)
4772 (let ((point-x (car (table--get-coordinate))))
4773 (table-recognize-cell 'force)
4774 (and (> point-x (car table-cell-info-lu-coordinate))
4775 (<= point-x (1- (car table-cell-info-rb-coordinate)))))))
4776
4777(defun table--cell-can-split-vertically-p ()
4778 "Test if a cell can split at current location vertically."
4779 (and (not buffer-read-only)
4780 (let ((point-y (cdr (table--get-coordinate))))
4781 (table-recognize-cell 'force)
4782 (and (> point-y (cdr table-cell-info-lu-coordinate))
4783 (<= point-y (cdr table-cell-info-rb-coordinate))))))
4784
4785(defun table--cell-can-span-p (direction)
4786 "Test if the current cell can span to DIRECTION."
4787 (table-recognize-cell 'force)
4788 (and (not buffer-read-only)
4789 (table--probe-cell)
4790 ;; get two adjacent cells from each corner
4791 (let ((cell (save-excursion
4792 (and
4793 (table--goto-coordinate
4794 (cons (cond ((eq direction 'right) (1+ (car table-cell-info-rb-coordinate)))
4795 ((eq direction 'left) (1- (car table-cell-info-lu-coordinate)))
4796 (t (car table-cell-info-lu-coordinate)))
4797 (cond ((eq direction 'above) (- (cdr table-cell-info-lu-coordinate) 2))
4798 ((eq direction 'below) (+ (cdr table-cell-info-rb-coordinate) 2))
4799 (t (cdr table-cell-info-lu-coordinate)))) 'no-extension)
4800 (table--probe-cell))))
4801 (cell2 (save-excursion
4802 (and
4803 (table--goto-coordinate
4804 (cons (cond ((eq direction 'right) (1+ (car table-cell-info-rb-coordinate)))
4805 ((eq direction 'left) (1- (car table-cell-info-lu-coordinate)))
4806 (t (car table-cell-info-rb-coordinate)))
4807 (cond ((eq direction 'above) (- (cdr table-cell-info-lu-coordinate) 2))
4808 ((eq direction 'below) (+ (cdr table-cell-info-rb-coordinate) 2))
4809 (t (cdr table-cell-info-rb-coordinate)))) 'no-extension)
4810 (table--probe-cell)))))
4811 ;; make sure the two cells exist, and they are identical, that cell's size matches the current one
4812 (and cell
4813 (equal cell cell2)
4814 (if (or (eq direction 'right) (eq direction 'left))
4815 (and (= (cdr (table--get-coordinate (car cell)))
4816 (cdr table-cell-info-lu-coordinate))
4817 (= (cdr (table--get-coordinate (cdr cell)))
4818 (cdr table-cell-info-rb-coordinate)))
4819 (and (= (car (table--get-coordinate (car cell)))
4820 (car table-cell-info-lu-coordinate))
4821 (= (car (table--get-coordinate (cdr cell)))
4822 (car table-cell-info-rb-coordinate))))))))
4823
4824(defun table--cell-insert-char (char &optional overwrite)
4825 "Insert CHAR inside a table cell."
4826 (let ((delete-selection-p (and (boundp 'delete-selection-mode)
4827 delete-selection-mode
4828 transient-mark-mode mark-active
4829 (not buffer-read-only)))
4830 (mark-coordinate (table--transcoord-table-to-cache (table--get-coordinate (mark t)))))
4831 (table-with-cache-buffer
4832 (and delete-selection-p
4833 (>= (car mark-coordinate) 0)
4834 (<= (car mark-coordinate) table-cell-info-width)
4835 (>= (cdr mark-coordinate) 0)
4836 (<= (cdr mark-coordinate) table-cell-info-height)
4837 (save-excursion
4838 (delete-region (point) (table--goto-coordinate mark-coordinate))))
4839 (if overwrite
4840 (let ((coordinate (table--get-coordinate)))
4841 (setq table-inhibit-auto-fill-paragraph t)
4842 (if (>= (car coordinate) table-cell-info-width)
4843 (if (>= (cdr coordinate) (1- table-cell-info-height))
4844 (insert "\n" char)
4845 (forward-line 1)
4846 (insert char)
4847 (unless (eolp)
4848 (delete-char 1)))
4849 (insert char)
4850 (unless (eolp)
4851 (delete-char 1))))
4852 (if (not (eq char ?\ ))
4853 (if char (insert char))
4854 (if (not (looking-at "\\s *$"))
4855 (if (and table-fixed-width-mode
4856 (> (point) 2)
4857 (save-excursion
4858 (forward-char -2)
4859 (looking-at (concat "\\("
4860 (regexp-quote (char-to-string table-word-continuation-char))
4861 "\\)\n"))))
4862 (save-excursion
4863 (replace-match " " nil nil nil 1))
4864 (insert char))
4865 (let ((coordinate (table--get-coordinate)))
4866 (if (< (car coordinate) table-cell-info-width)
4867 (move-to-column (1+ (car coordinate)) t)
4868 (insert (make-string (forward-line 1) ?\n))
4869 (unless (bolp) (insert ?\n))))
4870 (setq table-inhibit-auto-fill-paragraph t))
4871 (save-excursion
4872 (let ((o-point (point)))
4873 (if (and (bolp)
4874 (or (progn
4875 (forward-paragraph)
4876 (forward-paragraph -1)
4877 (= o-point (point)))
4878 (progn
4879 (goto-char o-point)
4880 (forward-line)
4881 (setq o-point (point))
4882 (forward-paragraph)
4883 (forward-paragraph -1)
4884 (= o-point (point)))))
4885 (insert ?\n)))))))))
4886
4887(defun table--finish-delayed-tasks ()
4888 "Finish all outstanding delayed tasks."
4889 (if table-update-timer
4890 (table--update-cell 'now))
4891 (if table-widen-timer
4892 (table--update-cell-widened 'now))
4893 (if table-heighten-timer
4894 (table--update-cell-heightened 'now)))
4895
4896(defmacro table--log (&rest body)
4897 "Debug logging macro."
4898 `(save-excursion
4899 (set-buffer (get-buffer-create "log"))
4900 (goto-char (point-min))
4901 (let ((standard-output (current-buffer)))
4902 ,@body)))
4903
4904(defun table--measure-max-width (&optional unlimited)
4905 "Return maximum width of current buffer.
4906Normally the current buffer is expected to be already the cache
4907buffer. The width excludes following spaces at the end of each line.
4908Unless UNLIMITED is non-nil minimum return value is 1."
4909 (save-excursion
4910 (let ((width 0))
4911 (goto-char (point-min))
4912 (while
4913 (progn
4914 ;; do not count the following white spaces
4915 (re-search-forward "\\s *$")
4916 (goto-char (match-beginning 0))
4917 (if (> (current-column) width)
4918 (setq width (current-column)))
4919 (forward-line)
4920 (not (eobp))))
4921 (if unlimited width
4922 (max 1 width)))))
4923
4924(defun table--cell-to-coord (cell)
4925 "Create a cell coordinate pair from cell location pair."
4926 (if cell
4927 (cons (table--get-coordinate (car cell))
4928 (table--get-coordinate (cdr cell)))
4929 nil))
4930
4931(defun table--cell-list-to-coord-list (cell-list)
4932 "Create and return a coordinate list that corresponds to CELL-LIST.
4933CELL-LIST is a list of location pairs (lu . rb), where each pair
4934represents a cell in the list. lu is the left upper location and rb
4935is the right bottom location of a cell. The return value is a list of
4936coordinate pairs (lu-coord . rb-coord), where lu-coord is the left
4937upper coordinate and rb-coord is the right bottom coordinate of a
4938cell."
4939 (let ((coord-list))
4940 (while cell-list
4941 (let ((cell (prog1 (car cell-list) (setq cell-list (cdr cell-list)))))
4942 (setq coord-list
4943 (cons (table--cell-to-coord cell) coord-list))))
4944 (nreverse coord-list)))
4945
4946(defun table--test-cell-list (&optional horizontal reverse first-only pivot)
4947 "For testing `table--vertical-cell-list' and `table--horizontal-cell-list'."
4948 (let* ((current-coordinate (table--get-coordinate))
4949 (cell-list (if horizontal
4950 (table--horizontal-cell-list reverse first-only pivot)
4951 (table--vertical-cell-list reverse first-only pivot)))
4952 (count 0))
4953 (while cell-list
4954 (let* ((cell (if first-only (prog1 cell-list (setq cell-list nil))
4955 (prog1 (car cell-list) (setq cell-list (cdr cell-list)))))
4956 (dig1-str (format "%1d" (prog1 (% count 10) (setq count (1+ count))))))
4957 (goto-char (car cell))
4958 (table-with-cache-buffer
4959 (replace-regexp "." dig1-str)
4960 (setq table-inhibit-auto-fill-paragraph t))
4961 (table--finish-delayed-tasks)))
4962 (table--goto-coordinate current-coordinate)))
4963
4964(defun table--vertical-cell-list (&optional top-to-bottom first-only pivot internal-dir internal-list internal-px)
4965 "Return a vertical cell list from the table.
4966The return value represents a list of cells including the current cell
4967that align vertically. Each element of the list is a cons cell (lu
4968. rb) where lu is the cell's left upper location and rb is the cell's
4969right bottom location. The cell order in the list is from bottom to
4970top of the table. If optional argument TOP-TO-BOTTOM is non-nil the
4971order is reversed as from top to bottom of the table. If optional
4972argument FIRST-ONLY is non-nil the return value is not a list of cells
4973but a single cons cell that is the first cell of the list, if the list
4974had been created. If optional argument PIVOT is a symbol `left' the
4975vertical cell search is aligned with the left edge of the current
4976cell, otherwise aligned with the right edge of the current cell. The
4977arguments INTERNAL-DIR, INTERNAL-LIST and INTERNAL-PX are internal use
4978only and must not be specified."
4979 (save-excursion
4980 (let* ((cell (table--probe-cell))
4981 (lu-coordinate (table--get-coordinate (car cell)))
4982 (rb-coordinate (table--get-coordinate (cdr cell)))
4983 (px (or internal-px (car (if (eq pivot 'left) lu-coordinate rb-coordinate))))
4984 (ty (- (cdr lu-coordinate) 2))
4985 (by (+ (cdr rb-coordinate) 2)))
4986 ;; in case of finding the the first cell, get the last adding item on the list
4987 (if (and (null internal-dir) first-only) (setq top-to-bottom (null top-to-bottom)))
4988 ;; travel up and process as recursion traces back (reverse order)
4989 (and cell
4990 (or (eq internal-dir 'up) (null internal-dir))
4991 (table--goto-coordinate (cons px (if top-to-bottom by ty)) 'no-extension 'no-tab-expansion)
4992 (setq internal-list (table--vertical-cell-list top-to-bottom first-only nil 'up nil px)))
4993 ;; return the last cell or add this cell to the list
4994 (if first-only (or internal-list cell)
4995 (setq internal-list (if cell (cons cell internal-list) internal-list))
4996 ;; travel down and process as entering each recursion (forward order)
4997 (and cell
4998 (or (eq internal-dir 'down) (null internal-dir))
4999 (table--goto-coordinate (cons px (if top-to-bottom ty by)) 'no-extension 'no-tab-expansion)
5000 (setq internal-list (table--vertical-cell-list top-to-bottom nil nil 'down internal-list px)))
5001 ;; return the result
5002 internal-list))))
5003
5004(defun table--horizontal-cell-list (&optional left-to-right first-only pivot internal-dir internal-list internal-py)
5005 "Return a horizontal cell list from the table.
5006The return value represents a list of cells including the current cell
5007that align horizontally. Each element of the list is a cons cells (lu
5008. rb) where lu is the cell's left upper location and rb is the cell's
5009right bottom location. The cell order in the list is from right to
5010left of the table. If optional argument LEFT-TO-RIGHT is non-nil the
5011order is reversed as from left to right of the table. If optional
5012argument FIRST-ONLY is non-nil the return value is not a list of cells
5013but a single cons cell that is the first cell of the list, if the
5014list had been created. If optional argument PIVOT is a symbol `top'
5015the horizontal cell search is aligned with the top edge of the current
5016cell, otherwise aligned with the bottom edge of the current cell. The
5017arguments INTERNAL-DIR, INTERNAL-LIST and INTERNAL-PY are internal use
5018only and must not be specified."
5019 (save-excursion
5020 (let* ((cell (table--probe-cell))
5021 (lu-coordinate (table--get-coordinate (car cell)))
5022 (rb-coordinate (table--get-coordinate (cdr cell)))
5023 (py (or internal-py (if (eq pivot 'top) (cdr lu-coordinate) (1+ (cdr rb-coordinate)))))
5024 (lx (1- (car lu-coordinate)))
5025 (rx (1+ (car rb-coordinate))))
5026 ;; in case of finding the the first cell, get the last adding item on the list
5027 (if (and (null internal-dir) first-only) (setq left-to-right (null left-to-right)))
5028 ;; travel left and process as recursion traces back (reverse order)
5029 (and cell
5030 (or (eq internal-dir 'left) (null internal-dir))
5031 (table--goto-coordinate (cons (if left-to-right rx lx) py) 'no-extension 'no-tab-expansion)
5032 (setq internal-list (table--horizontal-cell-list left-to-right first-only nil 'left nil py)))
5033 ;; return the last cell or add this cell to the list
5034 (if first-only (or internal-list cell)
5035 (setq internal-list (if cell (cons cell internal-list) internal-list))
5036 ;; travel right and process as entering each recursion (forward order)
5037 (and cell
5038 (or (eq internal-dir 'right) (null internal-dir))
5039 (table--goto-coordinate (cons (if left-to-right lx rx) py) 'no-extension 'no-tab-expansion)
5040 (setq internal-list (table--horizontal-cell-list left-to-right nil nil 'right internal-list py)))
5041 ;; return the result
5042 internal-list))))
5043
5044(defun table--point-in-cell-p (&optional location)
5045 "Return t when point is in a valid table cell in the current buffer.
5046When optional LOCATION is provided the test is performed at that location."
5047 (and (table--at-cell-p (or location (point)))
5048 (if location
5049 (save-excursion
5050 (goto-char location)
5051 (table--probe-cell))
5052 (table--probe-cell))))
5053
5054(defun table--region-in-cell-p (beg end)
5055 "Return t when location BEG and END are in a valid table cell in the current buffer."
5056 (and (table--at-cell-p (min beg end))
5057 (save-excursion
5058 (let ((cell-beg (progn (goto-char beg) (table--probe-cell))))
5059 (and cell-beg
5060 (equal cell-beg (progn (goto-char end) (table--probe-cell))))))))
5061
5062(defun table--at-cell-p (position &optional object at-column)
5063 "Returns non-nil if POSITION has table-cell property in OBJECT.
5064OBJECT is optional and defaults to the current buffer.
5065If POSITION is at the end of OBJECT, the value is nil."
5066 (if (and at-column (stringp object))
5067 (setq position (table--str-index-at-column object position)))
5068 (get-text-property position 'table-cell object))
5069
5070(defun table--probe-cell-left-up ()
5071 "Probe left up corner pattern of a cell.
5072If it finds a valid corner returns a position otherwise returns nil.
5073The position is the location before the first cell character.
5074Focus only on the corner pattern. Further cell validity check is required."
5075 (save-excursion
5076 (let ((vertical-str (regexp-quote (char-to-string table-cell-vertical-char)))
5077 (intersection-str (regexp-quote (char-to-string table-cell-intersection-char)))
5078 (v-border (format "[%c%c]" table-cell-vertical-char table-cell-intersection-char))
e99add21 5079 (h-border (format "[%s%c]" table-cell-horizontal-chars table-cell-intersection-char))
238240c9
RS
5080 (limit (save-excursion (beginning-of-line) (point))))
5081 (catch 'end
5082 (while t
5083 (catch 'retry-horizontal
5084 (if (not (search-backward-regexp v-border limit t))
5085 (throw 'end nil))
5086 (save-excursion
5087 (let ((column (current-column)))
5088 (while t
5089 (catch 'retry-vertical
5090 (if (zerop (forward-line -1)) nil (throw 'end nil))
5091 (move-to-column column)
5092 (while (and (looking-at vertical-str)
5093 (= column (current-column)))
5094 (if (zerop (forward-line -1)) nil (throw 'end nil))
5095 (move-to-column column))
5096 (cond
5097 ((/= column (current-column))
5098 (throw 'end nil))
5099 ((looking-at (concat intersection-str h-border))
5100 (forward-line 1)
5101 (move-to-column column)
5102 (forward-char 1)
5103 (throw 'end (point)))
5104 ((looking-at intersection-str)
5105 (throw 'retry-vertical nil))
5106 (t (throw 'retry-horizontal nil)))))))))))))
5107
5108(defun table--probe-cell-right-bottom ()
5109 "Probe right bottom corner pattern of a cell.
5110If it finds a valid corner returns a position otherwise returns nil.
5111The position is the location after the last cell character.
5112Focus only on the corner pattern. Further cell validity check is required."
5113 (save-excursion
5114 (let ((vertical-str (regexp-quote (char-to-string table-cell-vertical-char)))
5115 (intersection-str (regexp-quote (char-to-string table-cell-intersection-char)))
5116 (v-border (format "[%c%c]" table-cell-vertical-char table-cell-intersection-char))
e99add21 5117 (h-border (format "[%s%c]" table-cell-horizontal-chars table-cell-intersection-char))
238240c9
RS
5118 (limit (save-excursion (end-of-line) (point))))
5119 (catch 'end
5120 (while t
5121 (catch 'retry-horizontal
5122 (if (not (search-forward-regexp v-border limit t))
5123 (throw 'end nil))
5124 (save-excursion
5125 (forward-char -1)
5126 (let ((column (current-column)))
5127 (while t
5128 (catch 'retry-vertical
5129 (while (and (looking-at vertical-str)
5130 (= column (current-column)))
5131 (if (and (zerop (forward-line 1)) (zerop (current-column))) nil (throw 'end nil))
5132 (move-to-column column))
5133 (cond
5134 ((/= column (current-column))
5135 (throw 'end nil))
5136 ((save-excursion (forward-char -1) (looking-at (concat h-border intersection-str)))
5137 (save-excursion
5138 (and (zerop (forward-line -1))
5139 (move-to-column column)
5140 (looking-at v-border)
5141 (throw 'end (point))))
5142 (forward-char 1)
5143 (throw 'retry-horizontal nil))
5144 ((looking-at intersection-str)
5145 (if (and (zerop (forward-line 1)) (zerop (current-column))) nil (throw 'end nil))
5146 (move-to-column column)
5147 (throw 'retry-vertical nil))
5148 (t (throw 'retry-horizontal nil)))))))))))))
5149
5150(defun table--editable-cell-p (&optional abort-on-error)
5151 (and (not buffer-read-only)
951f97e6 5152 (get-text-property (point) 'table-cell)))
238240c9
RS
5153
5154(defun table--probe-cell (&optional abort-on-error)
5155 "Probes a table cell around the point.
5156Searches for the left upper corner and the right bottom corner of a table
5157cell which contains the current point location.
5158
5159The result is a cons cell (left-upper . right-bottom) where
5160the left-upper is the position before the cell's left upper corner character,
5161the right-bottom is the position after the cell's right bottom corner character.
5162
5163When it fails to find either one of the cell corners it returns nil or
5164signals error if the optional ABORT-ON-ERROR is non-nil."
5165 (let (lu rb
e99add21
JB
5166 (border (format "^[%s%c%c]+$"
5167 table-cell-horizontal-chars
238240c9
RS
5168 table-cell-vertical-char
5169 table-cell-intersection-char)))
5170 (if (and (condition-case nil
5171 (progn
5172 (and (setq lu (table--probe-cell-left-up))
5173 (setq rb (table--probe-cell-right-bottom))))
5174 (error nil))
5175 (< lu rb)
5176 (let ((lu-coordinate (table--get-coordinate lu))
5177 (rb-coordinate (table--get-coordinate rb)))
5178 ;; test for valid upper and lower borders
5179 (and (string-match
5180 border
5181 (buffer-substring
5182 (save-excursion
5183 (table--goto-coordinate
5184 (cons (1- (car lu-coordinate))
5185 (1- (cdr lu-coordinate)))))
5186 (save-excursion
5187 (table--goto-coordinate
5188 (cons (1+ (car rb-coordinate))
5189 (1- (cdr lu-coordinate)))))))
5190 (string-match
5191 border
5192 (buffer-substring
5193 (save-excursion
5194 (table--goto-coordinate
5195 (cons (1- (car lu-coordinate))
5196 (1+ (cdr rb-coordinate)))))
5197 (save-excursion
5198 (table--goto-coordinate
5199 (cons (1+ (car rb-coordinate))
5200 (1+ (cdr rb-coordinate))))))))))
5201 (cons lu rb)
5202 (if abort-on-error
5203 (error "Table cell not found")
5204 nil))))
5205
5206(defun table--insert-rectangle (rectangle)
5207 "Insert text of RECTANGLE with upper left corner at point.
5208Same as insert-rectangle except that mark operation is eliminated."
5209 (let ((lines rectangle)
5210 (insertcolumn (current-column))
5211 (first t))
5212 (while lines
5213 (or first
5214 (progn
5215 (forward-line 1)
5216 (or (bolp) (insert ?\n))
5217 (move-to-column insertcolumn t)))
5218 (setq first nil)
5219 (insert (car lines))
5220 (setq lines (cdr lines)))))
5221
5222(defun table--put-cell-property (cell)
5223 "Put standard text properties to the CELL.
5224The CELL is a cons cell (left-upper . right-bottom) where the
5225left-upper is the position before the cell's left upper corner
5226character, the right-bottom is the position after the cell's right
5227bottom corner character."
5228 (let ((lu (table--get-coordinate (car cell)))
5229 (rb (table--get-coordinate (cdr cell))))
5230 (save-excursion
5231 (while (<= (cdr lu) (cdr rb))
5232 (let ((beg (table--goto-coordinate lu 'no-extension))
5233 (end (table--goto-coordinate (cons (car rb) (cdr lu)))))
5234 (table--put-cell-line-property beg end))
5235 (setcdr lu (1+ (cdr lu))))
5236 (table--put-cell-justify-property cell table-cell-info-justify)
5237 (table--put-cell-valign-property cell table-cell-info-valign))))
5238
5239(defun table--put-cell-line-property (beg end &optional object)
5240 "Put standard text properties to a line of a cell.
5241BEG is the beginning of the line that is the location between left
5242cell border character and the first content character. END is the end
5243of the line that is the location between the last content character
5244and the right cell border character."
5245 (table--put-cell-content-property beg end object)
5246 (table--put-cell-keymap-property end (1+ end) object)
5247 (table--put-cell-indicator-property end (1+ end) object)
5248 (table--put-cell-rear-nonsticky end (1+ end) object))
5249
5250(defun table--put-cell-content-property (beg end &optional object)
5251 "Put cell content text properties."
5252 (table--put-cell-keymap-property beg end object)
5253 (table--put-cell-indicator-property beg end object)
5254 (table--put-cell-face-property beg end object)
5255 (table--put-cell-point-entered/left-property beg end object))
5256
5257(defun table--put-cell-indicator-property (beg end &optional object)
5258 "Put cell property which indicates that the location is within a table cell."
d6db9101
EZ
5259 (put-text-property beg end 'table-cell t object)
5260 (put-text-property beg end 'yank-handler table-yank-handler object))
238240c9
RS
5261
5262(defun table--put-cell-face-property (beg end &optional object)
5263 "Put cell face property."
5264 (put-text-property beg end 'face 'table-cell-face object))
5265
5266(defun table--put-cell-keymap-property (beg end &optional object)
5267 "Put cell keymap property."
5268 (put-text-property beg end 'keymap 'table-cell-map object))
5269
5270(defun table--put-cell-rear-nonsticky (beg end &optional object)
5271 "Put rear-nonsticky property."
5272 (put-text-property beg end 'rear-nonsticky t object))
db95369b 5273
238240c9
RS
5274(defun table--put-cell-point-entered/left-property (beg end &optional object)
5275 "Put point-entered/left property."
5276 (put-text-property beg end 'point-entered 'table--point-entered-cell-function object)
5277 (put-text-property beg end 'point-left 'table--point-left-cell-function object))
5278
5279(defun table--remove-cell-properties (beg end &optional object)
5280 "Remove all cell properties.
5281If OBJECT is non-nil cell properties are removed from the OBJECT
5282instead of the current buffer and returns the OBJECT."
5283 (while (< beg end)
5284 (let ((next (next-single-property-change beg 'table-cell object end)))
5285 (if (get-text-property beg 'table-cell object)
5286 (remove-text-properties beg next
5287 (list
5288 'table-cell nil
5289 'table-justify nil
5290 'table-valign nil
5291 'face nil
5292 'rear-nonsticky nil
5293 'point-entered nil
5294 'point-left nil
5295 'keymap nil)
5296 object))
5297 (setq beg next)))
5298 object)
5299
5300(defun table--update-cell-face ()
5301 "Update cell face according to the current mode."
5302 (if (featurep 'xemacs)
5303 (set-face-property 'table-cell-face 'underline table-fixed-width-mode)
5304 (set-face-inverse-video-p 'table-cell-face table-fixed-width-mode)))
5305
5306(table--update-cell-face)
5307
5308(defun table--get-property (cell property)
5309 "Get CELL's PROPERTY."
5310 (or (get-text-property (car cell) property)
5311 (get-text-property (1- (cdr cell)) property)))
5312
5313(defun table--get-cell-justify-property (cell)
5314 "Get cell's justify property."
5315 (table--get-property cell 'table-justify))
5316
5317(defun table--get-cell-valign-property (cell)
5318 "Get cell's vertical alignment property."
5319 (table--get-property cell 'table-valign))
5320
5321(defun table--put-property (cell property value)
5322 "Put CELL's PROPERTY the VALUE."
5323 (let ((beg (car cell))
5324 (end (cdr cell)))
5325 (put-text-property beg (1+ beg) property value)
5326 (put-text-property (1- end) end property value)))
5327
5328(defun table--put-cell-justify-property (cell justify)
5329 "Put cell's justify property."
5330 (table--put-property cell 'table-justify justify))
5331
5332(defun table--put-cell-valign-property (cell valign)
5333 "Put cell's vertical alignment property."
5334 (table--put-property cell 'table-valign valign))
5335
5336(defun table--point-entered-cell-function (&optional old-point new-point)
5337 "Point has entered a cell.
5338Refresh the menu bar."
5339 (unless table-cell-entered-state
5340 (setq table-cell-entered-state t)
5341 (setq table-mode-indicator (not table-fixed-width-mode))
5342 (setq table-fixed-mode-indicator table-fixed-width-mode)
5343 (set-buffer-modified-p (buffer-modified-p))
5344 (table--warn-incompatibility)
5345 (run-hooks 'table-point-entered-cell-hook)))
5346
5347(defun table--point-left-cell-function (&optional old-point new-point)
5348 "Point has left a cell.
5349Refresh the menu bar."
5350 (when table-cell-entered-state
5351 (setq table-cell-entered-state nil)
5352 (setq table-mode-indicator nil)
5353 (setq table-fixed-mode-indicator nil)
5354 (set-buffer-modified-p (buffer-modified-p))
5355 (run-hooks 'table-point-left-cell-hook)))
5356
5357(defun table--warn-incompatibility ()
5358 "If called from interactive operation warn the know incompatibilities.
5359This feature is disabled when `table-disable-incompatibility-warning'
5360is non-nil. The warning is done only once per session for each item."
5361 (unless (and table-disable-incompatibility-warning
5362 (not (interactive-p)))
5363 (cond ((and (featurep 'xemacs)
5364 (not (get 'table-disable-incompatibility-warning 'xemacs)))
5365 (put 'table-disable-incompatibility-warning 'xemacs t)
5366 (momentary-string-display
5367 "
5368*** Warning ***
5369
5370Table package mostly works fine under XEmacs, however, due to the
5371peculiar implementation of text property under XEmacs, cell splitting
5372and any undo operation of table exhibit some known strange problems,
5373such that a border characters dissolve into adjacent cells. Please be
5374aware of this.
5375
5376"
5377 (save-excursion (forward-line 1) (point))))
5378 ((and (boundp 'flyspell-mode)
5379 flyspell-mode
5380 (not (get 'table-disable-incompatibility-warning 'flyspell)))
5381 (put 'table-disable-incompatibility-warning 'flyspell t)
5382 (momentary-string-display
5383 "
5384*** Warning ***
5385
5386Flyspell minor mode is known to be incompatible with this table
5387package. The flyspell version 1.5d at http://kaolin.unice.fr/~serrano
5388works better than the previous versions however not fully compatible.
5389
5390"
5391 (save-excursion (forward-line 1) (point))))
5392 )))
5393
5394(defun table--cell-blank-str (&optional n)
5395 "Return blank table cell string of length N."
5396 (let ((str (make-string (or n 1) ?\ )))
5397 (table--put-cell-content-property 0 (length str) str)
5398 str))
5399
5400(defun table--remove-eol-spaces (beg end &optional bol force)
5401 "Remove spaces at the end of each line in the BEG END region of the current buffer.
5402When optional BOL is non-nil spaces at the beginning of line are
5403removed. When optional FORCE is non-nil removal operation is enforced
5404even when point is within the removal area."
5405 (if (> beg end)
5406 (let ((tmp beg))
5407 (setq beg end)
5408 (setq end tmp)))
5409 (let ((saved-point (point-marker))
5410 (end-marker (copy-marker end)))
5411 (save-excursion
5412 (goto-char beg)
5413 (while (if bol (re-search-forward "^\\( +\\)" end-marker t)
5414 (re-search-forward "\\( +\\)$" end-marker t))
5415 ;; avoid removal that causes the saved point to lose its location.
5416 (if (and (null bol)
5417 (<= (match-beginning 1) saved-point)
5418 (<= saved-point (match-end 1))
5419 (not force))
5420 (delete-region saved-point (match-end 1))
5421 (delete-region (match-beginning 1) (match-end 1)))))
5422 (set-marker saved-point nil)
5423 (set-marker end-marker nil)))
5424
5425(defun table--fill-region (beg end &optional col justify)
5426 "Fill paragraphs in table cell cache.
5427Current buffer must already be set to the cache buffer."
5428 (let ((fill-column (or col table-cell-info-width))
5429 (fill-prefix nil)
5430 (enable-kinsoku nil)
5431 (adaptive-fill-mode nil)
5432 (marker-beg (copy-marker beg))
5433 (marker-end (copy-marker end))
5434 (marker-point (point-marker)))
5435 (setq justify (or justify table-cell-info-justify))
5436 (and justify
5437 (not (eq justify 'left))
5438 (not (featurep 'xemacs))
5439 (set-marker-insertion-type marker-point t))
5440 (table--remove-eol-spaces (point-min) (point-max))
5441 (if table-fixed-width-mode
5442 (table--fill-region-strictly marker-beg marker-end)
5443 (let ((paragraph-start table-paragraph-start))
5444 (fill-region marker-beg marker-end justify nil t)))
5445 (goto-char marker-point)
5446 (set-marker marker-beg nil)
5447 (set-marker marker-end nil)
5448 (set-marker marker-point nil)))
5449
5450(defun table--fill-region-strictly (beg end)
5451 "Fill region strictly so that no line exceeds fill-column.
5452When a word exceeds fill-column the word is chopped into pieces. The
5453chopped location is indicated with table-word-continuation-char."
5454 (or (and (markerp beg) (markerp end))
5455 (error "markerp"))
5456 (if (< fill-column 2)
5457 (setq fill-column 2))
5458 ;; first remove all continuation characters.
5459 (goto-char beg)
5460 (while (re-search-forward (concat
5461 (format "[^%c ]\\(" table-word-continuation-char)
5462 (regexp-quote (char-to-string table-word-continuation-char))
5463 "\\s +\\)")
5464 end t)
5465 (delete-region (match-beginning 1) (match-end 1)))
5466 ;; then fill as normal
5467 (let ((paragraph-start table-paragraph-start))
5468 (fill-region beg end nil nil t))
5469 ;; now fix up
5470 (goto-char beg)
5471 (while (let ((col (move-to-column fill-column t)))
5472 (cond
5473 ((and (<= col fill-column)
5474 (looking-at " *$"))
5475 (delete-region (match-beginning 0) (match-end 0))
5476 (and (zerop (forward-line 1))
5477 (< (point) end)))
5478 (t (forward-char -1)
5479 (insert-before-markers (if (equal (char-before) ?\ ) ?\ table-word-continuation-char)
5480 "\n")
5481 t)))))
5482
5483(defun table--goto-coordinate (coordinate &optional no-extension no-tab-expansion)
5484 "Move point to the given COORDINATE and return the location.
5485When optional NO-EXTENSION is non-nil and the specified coordinate is
5486not reachable returns nil otherwise the blanks are added if necessary
5487to achieve the goal coordinate and returns the goal point. It
5488intentionally does not preserve the original point in case it fails
5489achieving the goal. When optional NO-TAB-EXPANSION is non-nil and the
5490goad happens to be in a tab character the tab is not expanded but the
5491goal ends at the beginning of tab."
5492 (if (or (null coordinate)
5493 (< (car coordinate) 0)
5494 (< (cdr coordinate) 0)) nil
5495 (goto-char (point-min))
5496 (let ((x (car coordinate))
5497 (more-lines (forward-line (cdr coordinate))))
5498 (catch 'exit
5499 (if (zerop (current-column)) nil
5500 (if no-extension
5501 (progn
5502 (move-to-column x)
5503 (throw 'exit nil))
5504 (setq more-lines (1+ more-lines))))
5505 (if (zerop more-lines) nil
5506 (newline more-lines))
5507 (if no-extension
5508 (if (/= (move-to-column x) x)
5509 (if (> (move-to-column x) x)
5510 (if no-tab-expansion
5511 (progn
5512 (while (> (move-to-column x) x)
5513 (setq x (1- x)))
5514 (point))
5515 (throw 'exit (move-to-column x t)))
5516 (throw 'exit nil)))
5517 (move-to-column x t))
5518 (point)))))
5519
5520(defun table--copy-coordinate (coord)
5521 "Copy coordinate in a new cons cell."
5522 (cons (car coord) (cdr coord)))
5523
5524(defun table--get-coordinate (&optional where)
5525 "Return the coordinate of point in current buffer.
5526When optional WHERE is given it returns the coordinate of that
5527location instead of point in the current buffer. It does not move the
5528point"
5529 (save-excursion
5530 (if where (goto-char where))
5531 (cons (current-column)
5532 (table--current-line))))
5533
5534(defun table--current-line (&optional location)
5535 "Return zero based line count of current line or if non-nil LOCATION line."
5536 (save-excursion
5537 (if location (goto-char location))
5538 (beginning-of-line)
5539 (count-lines (point-min) (point))))
5540
5541(defun table--transcoord-table-to-cache (&optional coordinate)
5542 "Transpose COORDINATE from table coordinate system to cache coordinate system.
5543When COORDINATE is omitted or nil the point in current buffer is assumed in place."
5544 (table--offset-coordinate
5545 (or coordinate (table--get-coordinate))
5546 table-cell-info-lu-coordinate
5547 'negative))
5548
5549(defun table--transcoord-cache-to-table (&optional coordinate)
5550 "Transpose COORDINATE from cache coordinate system to table coordinate system.
5551When COORDINATE is omitted or nil the point in current buffer is assumed in place."
5552 (table--offset-coordinate
5553 (or coordinate (table--get-coordinate))
5554 table-cell-info-lu-coordinate))
5555
5556(defun table--offset-coordinate (coordinate offset &optional negative)
5557 "Return the offseted COORDINATE by OFFSET.
5558When optional NEGATIVE is non-nil offsetting direction is negative."
5559 (cons (if negative (- (car coordinate) (car offset))
5560 (+ (car coordinate) (car offset)))
5561 (if negative (- (cdr coordinate) (cdr offset))
5562 (+ (cdr coordinate) (cdr offset)))))
5563
5564(defun table--char-in-str-at-column (str column)
5565 "Return the character in STR at COLUMN location.
5566When COLUMN is out of range it returns null character."
5567 (let ((idx (table--str-index-at-column str column)))
5568 (if idx (aref str idx)
5569 ?\0)))
5570
5571(defun table--str-index-at-column (str column)
5572 "Return the character index in STR that corresponds to COLUMN location.
5573It returns COLUMN unless STR contains some wide characters."
5574 (let ((col 0)
5575 (idx 0)
5576 (len (length str)))
5577 (while (and (< col column) (< idx len))
5578 (setq col (+ col (char-width (aref str idx))))
5579 (setq idx (1+ idx)))
5580 (if (< idx len)
5581 idx
5582 nil)))
5583
5584(defun table--set-timer (seconds func args)
5585 "Generic wrapper for setting up a timer."
5586 (if (featurep 'xemacs)
5587 ;; the picky xemacs refuses to accept zero
5588 (add-timeout (if (zerop seconds) 0.01 seconds) func args nil)
5589 ;;(run-at-time seconds nil func args)))
5590 ;; somehow run-at-time causes strange problem under Emacs 20.7
5591 ;; this problem does not show up under Emacs 21.0.90
5592 (run-with-idle-timer seconds nil func args)))
5593
5594(defun table--cancel-timer (timer)
5595 "Generic wrapper for canceling a timer."
5596 (if (featurep 'xemacs)
5597 (disable-timeout timer)
5598 (cancel-timer timer)))
5599
5600(defun table--get-last-command ()
5601 "Generic wrapper for getting the real last command."
5602 (if (boundp 'real-last-command)
5603 real-last-command
5604 last-command))
5605
5606(run-hooks 'table-load-hook)
5607
5608(provide 'table)
5609
5610;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5611;; Local Variables: ***
5612;; time-stamp-line-limit: 16 ***
5613;; time-stamp-start: ";; Revised:[ \t]+" ***
5614;; time-stamp-end: "$" ***
5615;; time-stamp-format: "%3a %3b %02d %:y %02H:%02M:%02S (%Z)" ***
5616;; End: ***
5617;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5618
951f97e6 5619;; arch-tag: 0d69b03e-aa5f-4e72-8806-5727217617e0
238240c9 5620;;; table.el ends here