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