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