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