Add ibuffer-filter-by-derived-mode to ibuffer menu and doc
[emacs.git] / lisp / textmodes / table.el
blob3d9f88a43c9570e92383522967d6df754723da5f
1 ;;; table.el --- create and edit WYSIWYG text based embedded tables -*- lexical-binding: t -*-
3 ;; Copyright (C) 2000-2012 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}
1575 (interactive
1576 (progn
1577 (barf-if-buffer-read-only)
1578 (if (table--probe-cell)
1579 (error "Can't insert a table inside a table"))
1580 (mapcar (function table--read-from-minibuffer)
1581 '(("Number of columns" . table-columns-history)
1582 ("Number of rows" . table-rows-history)
1583 ("Cell width(s)" . table-cell-width-history)
1584 ("Cell height(s)" . table-cell-height-history)))))
1585 (table--make-cell-map)
1586 ;; reform the arguments.
1587 (if (null cell-width) (setq cell-width (car table-cell-width-history)))
1588 (if (null cell-height) (setq cell-height (car table-cell-height-history)))
1589 (if (stringp columns) (setq columns (string-to-number columns)))
1590 (if (stringp rows) (setq rows (string-to-number rows)))
1591 (if (stringp cell-width) (setq cell-width (table--string-to-number-list cell-width)))
1592 (if (stringp cell-height) (setq cell-height (table--string-to-number-list cell-height)))
1593 (if (numberp cell-width) (setq cell-width (cons cell-width nil)))
1594 (if (numberp cell-height) (setq cell-height (cons cell-height nil)))
1595 ;; test validity of the arguments.
1596 (mapc (lambda (arg)
1597 (let* ((value (symbol-value arg))
1598 (error-handler
1599 (function (lambda ()
1600 (error "%s must be a positive integer%s" arg
1601 (if (listp value) " or a list of positive integers" ""))))))
1602 (if (null value) (funcall error-handler))
1603 (mapcar (function (lambda (arg1)
1604 (if (or (not (integerp arg1))
1605 (< arg1 1))
1606 (funcall error-handler))))
1607 (if (listp value) value
1608 (cons value nil)))))
1609 '(columns rows cell-width cell-height))
1610 (let ((orig-coord (table--get-coordinate))
1611 (coord (table--get-coordinate))
1612 r i cw ch cell-str border-str)
1613 ;; prefabricate the building blocks border-str and cell-str.
1614 (with-temp-buffer
1615 ;; construct border-str
1616 (insert table-cell-intersection-char)
1617 (setq cw cell-width)
1618 (setq i 0)
1619 (while (< i columns)
1620 (insert (make-string (car cw) (string-to-char table-cell-horizontal-chars)) table-cell-intersection-char)
1621 (if (cdr cw) (setq cw (cdr cw)))
1622 (setq i (1+ i)))
1623 (setq border-str (buffer-substring (point-min) (point-max)))
1624 ;; construct cell-str
1625 (erase-buffer)
1626 (insert table-cell-vertical-char)
1627 (setq cw cell-width)
1628 (setq i 0)
1629 (while (< i columns)
1630 (let ((beg (point)))
1631 (insert (make-string (car cw) ?\s))
1632 (insert table-cell-vertical-char)
1633 (table--put-cell-line-property beg (1- (point))))
1634 (if (cdr cw) (setq cw (cdr cw)))
1635 (setq i (1+ i)))
1636 (setq cell-str (buffer-substring (point-min) (point-max))))
1637 ;; if the construction site has an empty border push that border down.
1638 (save-excursion
1639 (beginning-of-line)
1640 (if (looking-at "\\s *$")
1641 (progn
1642 (setq border-str (concat border-str "\n"))
1643 (setq cell-str (concat cell-str "\n")))))
1644 ;; now build the table using the prefabricated building blocks
1645 (setq r 0)
1646 (setq ch cell-height)
1647 (while (< r rows)
1648 (if (> r 0) nil
1649 (table--goto-coordinate coord) (setcdr coord (1+ (cdr coord)))
1650 (table--untabify-line (point))
1651 (insert border-str))
1652 (setq i 0)
1653 (while (< i (car ch))
1654 (table--goto-coordinate coord) (setcdr coord (1+ (cdr coord)))
1655 (table--untabify-line (point))
1656 (insert cell-str)
1657 (setq i (1+ i)))
1658 (table--goto-coordinate coord) (setcdr coord (1+ (cdr coord)))
1659 (table--untabify-line (point))
1660 (insert border-str)
1661 (if (cdr ch) (setq ch (cdr ch)))
1662 (setq r (1+ r)))
1663 ;; stand by at the first cell
1664 (table--goto-coordinate (table--offset-coordinate orig-coord '(1 . 1)))
1665 (table-recognize-cell 'force)))
1667 ;;;###autoload
1668 (defun table-insert-row (n)
1669 "Insert N table row(s).
1670 When point is in a table the newly inserted row(s) are placed above
1671 the current row. When point is outside of the table it must be below
1672 the table within the table width range, then the newly created row(s)
1673 are appended at the bottom of the table."
1674 (interactive "*p")
1675 (if (< n 0) (setq n 1))
1676 (let* ((current-coordinate (table--get-coordinate))
1677 (coord-list (table--cell-list-to-coord-list (table--horizontal-cell-list t nil 'top)))
1678 (append-row (if coord-list nil (setq coord-list (table--find-row-column))))
1679 (cell-height (cdr (table--min-coord-list coord-list)))
1680 (left-list nil)
1681 (this-list coord-list)
1682 (right-list (cdr coord-list))
1683 (bottom-border-y (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))
1684 (vertical-str (string table-cell-vertical-char))
1685 (vertical-str-with-properties (let ((str (string table-cell-vertical-char)))
1686 (table--put-cell-keymap-property 0 (length str) str)
1687 (table--put-cell-rear-nonsticky 0 (length str) str) str))
1688 (first-time t))
1689 ;; create the space below for the table to grow
1690 (table--create-growing-space-below (* n (+ 1 cell-height)) coord-list bottom-border-y)
1691 ;; vertically expand each cell from left to right
1692 (while this-list
1693 (let* ((left (prog1 (car left-list) (setq left-list (if left-list (cdr left-list) coord-list))))
1694 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
1695 (right (prog1 (car right-list) (setq right-list (cdr right-list))))
1696 (exclude-left (and left (< (cdar left) (cdar this))))
1697 (exclude-right (and right (<= (cdar right) (cdar this))))
1698 (beg (table--goto-coordinate
1699 (cons (if exclude-left (caar this) (1- (caar this)))
1700 (cdar this))))
1701 (end (table--goto-coordinate
1702 (cons (if exclude-right (cadr this) (1+ (cadr this)))
1703 bottom-border-y)))
1704 (rect (if append-row nil (extract-rectangle beg end))))
1705 ;; prepend blank cell lines to the extracted rectangle
1706 (let ((i n))
1707 (while (> i 0)
1708 (setq rect (cons
1709 (concat (if exclude-left "" (char-to-string table-cell-intersection-char))
1710 (make-string (- (cadr this) (caar this)) (string-to-char table-cell-horizontal-chars))
1711 (if exclude-right "" (char-to-string table-cell-intersection-char)))
1712 rect))
1713 (let ((j cell-height))
1714 (while (> j 0)
1715 (setq rect (cons
1716 (concat (if exclude-left ""
1717 (if first-time vertical-str vertical-str-with-properties))
1718 (table--cell-blank-str (- (cadr this) (caar this)))
1719 (if exclude-right "" vertical-str-with-properties))
1720 rect))
1721 (setq j (1- j))))
1722 (setq i (1- i))))
1723 (setq first-time nil)
1724 (if append-row
1725 (table--goto-coordinate (cons (if exclude-left (caar this) (1- (caar this)))
1726 (1+ bottom-border-y)))
1727 (delete-rectangle beg end)
1728 (goto-char beg))
1729 (table--insert-rectangle rect)))
1730 ;; fix up the intersections
1731 (setq this-list (if append-row nil coord-list))
1732 (while this-list
1733 (let ((this (prog1 (car this-list) (setq this-list (cdr this-list))))
1734 (i 0))
1735 (while (< i n)
1736 (let ((y (1- (* i (+ 1 cell-height)))))
1737 (table--goto-coordinate (table--offset-coordinate (car this) (cons -1 y)))
1738 (delete-char 1) (insert table-cell-intersection-char)
1739 (table--goto-coordinate (table--offset-coordinate (cons (cadr this) (cdar this)) (cons 0 y)))
1740 (delete-char 1) (insert table-cell-intersection-char)
1741 (setq i (1+ i))))))
1742 ;; move the point to the beginning of the first newly inserted cell.
1743 (if (table--goto-coordinate
1744 (if append-row (cons (car (caar coord-list)) (1+ bottom-border-y))
1745 (caar coord-list))) nil
1746 (table--goto-coordinate current-coordinate))
1747 ;; re-recognize the current cell's new dimension
1748 (table-recognize-cell 'force)))
1750 ;;;###autoload
1751 (defun table-insert-column (n)
1752 "Insert N table column(s).
1753 When point is in a table the newly inserted column(s) are placed left
1754 of the current column. When point is outside of the table it must be
1755 right side of the table within the table height range, then the newly
1756 created column(s) are appended at the right of the table."
1757 (interactive "*p")
1758 (if (< n 0) (setq n 1))
1759 (let* ((current-coordinate (table--get-coordinate))
1760 (coord-list (table--cell-list-to-coord-list (table--vertical-cell-list t nil 'left)))
1761 (append-column (if coord-list nil (setq coord-list (table--find-row-column 'column))))
1762 (cell-width (car (table--min-coord-list coord-list)))
1763 (border-str (table--multiply-string (concat (make-string cell-width (string-to-char table-cell-horizontal-chars))
1764 (char-to-string table-cell-intersection-char)) n))
1765 (cell-str (table--multiply-string (concat (table--cell-blank-str cell-width)
1766 (let ((str (string table-cell-vertical-char)))
1767 (table--put-cell-keymap-property 0 (length str) str)
1768 (table--put-cell-rear-nonsticky 0 (length str) str) str)) n))
1769 (columns-to-extend (* n (+ 1 cell-width)))
1770 (above-list nil)
1771 (this-list coord-list)
1772 (below-list (cdr coord-list))
1773 (right-border-x (car (table--get-coordinate (cdr (table--horizontal-cell-list nil t))))))
1774 ;; push back the affected area above and below this table
1775 (table--horizontally-shift-above-and-below columns-to-extend coord-list)
1776 ;; process each cell vertically from top to bottom
1777 (while this-list
1778 (let* ((above (prog1 (car above-list) (setq above-list (if above-list (cdr above-list) coord-list))))
1779 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
1780 (below (prog1 (car below-list) (setq below-list (cdr below-list))))
1781 (exclude-above (and above (<= (caar above) (caar this))))
1782 (exclude-below (and below (< (caar below) (caar this))))
1783 (beg-coord (cons (if append-column (1+ right-border-x) (caar this))
1784 (if exclude-above (cdar this) (1- (cdar this)))))
1785 (end-coord (cons (1+ right-border-x)
1786 (if exclude-below (cddr this) (1+ (cddr this)))))
1787 rect)
1788 ;; untabify the area right of the bar that is about to be inserted
1789 (let ((coord (table--copy-coordinate beg-coord))
1790 (i 0)
1791 (len (length rect)))
1792 (while (< i len)
1793 (if (table--goto-coordinate coord 'no-extension)
1794 (table--untabify-line (point)))
1795 (setcdr coord (1+ (cdr coord)))
1796 (setq i (1+ i))))
1797 ;; extract and delete the rectangle area including the current
1798 ;; cell and to the right border of the table.
1799 (setq rect (extract-rectangle (table--goto-coordinate beg-coord)
1800 (table--goto-coordinate end-coord)))
1801 (delete-rectangle (table--goto-coordinate beg-coord)
1802 (table--goto-coordinate end-coord))
1803 ;; prepend the empty column string at the beginning of each
1804 ;; rectangle string extracted before.
1805 (let ((rect-str rect)
1806 (first t))
1807 (while rect-str
1808 (if (and first (null exclude-above))
1809 (setcar rect-str (concat border-str (car rect-str)))
1810 (if (and (null (cdr rect-str)) (null exclude-below))
1811 (setcar rect-str (concat border-str (car rect-str)))
1812 (setcar rect-str (concat cell-str (car rect-str)))))
1813 (setq first nil)
1814 (setq rect-str (cdr rect-str))))
1815 ;; insert the extended rectangle
1816 (table--goto-coordinate beg-coord)
1817 (table--insert-rectangle rect)))
1818 ;; fix up the intersections
1819 (setq this-list (if append-column nil coord-list))
1820 (while this-list
1821 (let ((this (prog1 (car this-list) (setq this-list (cdr this-list))))
1822 (i 0))
1823 (while (< i n)
1824 (let ((x (1- (* (1+ i) (+ 1 cell-width)))))
1825 (table--goto-coordinate (table--offset-coordinate (car this) (cons x -1)))
1826 (delete-char 1) (insert table-cell-intersection-char)
1827 (table--goto-coordinate (table--offset-coordinate (cons (caar this) (cddr this)) (cons x 1)))
1828 (delete-char 1) (insert table-cell-intersection-char)
1829 (setq i (1+ i))))))
1830 ;; move the point to the beginning of the first newly inserted cell.
1831 (if (table--goto-coordinate
1832 (if append-column
1833 (cons (1+ right-border-x)
1834 (cdar (car coord-list)))
1835 (caar coord-list))) nil
1836 (table--goto-coordinate current-coordinate))
1837 ;; re-recognize the current cell's new dimension
1838 (table-recognize-cell 'force)))
1840 ;;;###autoload
1841 (defun table-insert-row-column (row-column n)
1842 "Insert row(s) or column(s).
1843 See `table-insert-row' and `table-insert-column'."
1844 (interactive
1845 (let ((n (prefix-numeric-value current-prefix-arg)))
1846 (if (< n 0) (setq n 1))
1847 (list (intern (let ((completion-ignore-case t)
1848 (default (car table-insert-row-column-history)))
1849 (downcase (completing-read
1850 (format "Insert %s row%s/column%s (default %s): "
1851 (if (> n 1) (format "%d" n) "a")
1852 (if (> n 1) "s" "")
1853 (if (> n 1) "s" "")
1854 default)
1855 '(("row") ("column"))
1856 nil t nil 'table-insert-row-column-history default))))
1857 n)))
1858 (cond ((eq row-column 'row)
1859 (table-insert-row n))
1860 ((eq row-column 'column)
1861 (table-insert-column n))))
1863 ;;;###autoload
1864 (defun table-recognize (&optional arg)
1865 "Recognize all tables within the current buffer and activate them.
1866 Scans the entire buffer and recognizes valid table cells. If the
1867 optional numeric prefix argument ARG is negative the tables in the
1868 buffer become inactive, meaning the tables become plain text and loses
1869 all the table specific features."
1870 (interactive "P")
1871 (setq arg (prefix-numeric-value arg))
1872 (let* ((inhibit-read-only t))
1873 (table-recognize-region (point-min) (point-max) -1)
1874 (if (>= arg 0)
1875 (save-excursion
1876 (goto-char (point-min))
1877 (let* ((border (format "[%s%c%c]"
1878 table-cell-horizontal-chars
1879 table-cell-vertical-char
1880 table-cell-intersection-char))
1881 (border3 (concat border border border))
1882 (non-border (format "^[^%s%c%c]*$"
1883 table-cell-horizontal-chars
1884 table-cell-vertical-char
1885 table-cell-intersection-char)))
1886 ;; `table-recognize-region' is an expensive function so minimize
1887 ;; the search area. A minimum table at least consists of three consecutive
1888 ;; table border characters to begin with such as
1889 ;; +-+
1890 ;; |A|
1891 ;; +-+
1892 ;; and any tables end with a line containing no table border characters
1893 ;; or the end of buffer.
1894 (while (and (re-search-forward border3 (point-max) t)
1895 (not (and (input-pending-p)
1896 table-abort-recognition-when-input-pending)))
1897 (message "Recognizing tables...(%d%%)" (/ (* 100 (match-beginning 0)) (- (point-max) (point-min))))
1898 (let ((beg (match-beginning 0))
1899 end)
1900 (if (re-search-forward non-border (point-max) t)
1901 (setq end (match-beginning 0))
1902 (setq end (goto-char (point-max))))
1903 (table-recognize-region beg end arg)))
1904 (message "Recognizing tables...done"))))))
1906 ;;;###autoload
1907 (defun table-unrecognize ()
1908 (interactive)
1909 (table-recognize -1))
1911 ;;;###autoload
1912 (defun table-recognize-region (beg end &optional arg)
1913 "Recognize all tables within region.
1914 BEG and END specify the region to work on. If the optional numeric
1915 prefix argument ARG is negative the tables in the region become
1916 inactive, meaning the tables become plain text and lose all the table
1917 specific features."
1918 (interactive "r\nP")
1919 (setq arg (prefix-numeric-value arg))
1920 (let ((inhibit-read-only t)
1921 (modified-flag (buffer-modified-p)))
1922 (if (< arg 0)
1923 (table--remove-cell-properties beg end)
1924 (save-excursion
1925 (goto-char beg)
1926 (let* ((border (format "[%s%c%c]"
1927 table-cell-horizontal-chars
1928 table-cell-vertical-char
1929 table-cell-intersection-char))
1930 (non-border (format "[^%s%c%c]"
1931 table-cell-horizontal-chars
1932 table-cell-vertical-char
1933 table-cell-intersection-char))
1934 (inhibit-read-only t))
1935 (unwind-protect
1936 (progn
1937 (remove-text-properties beg end '(table-cell nil))
1938 (while (and (< (point) end)
1939 (not (and (input-pending-p)
1940 table-abort-recognition-when-input-pending)))
1941 (cond
1942 ((looking-at "\n")
1943 (forward-char 1))
1944 ((looking-at border)
1945 (if (re-search-forward non-border end t)
1946 (goto-char (match-beginning 0))
1947 (goto-char end)))
1948 ((table--at-cell-p (point))
1949 (goto-char (next-single-property-change (point) 'table-cell nil end)))
1951 (let ((cell (table-recognize-cell 'force 'no-copy)))
1952 (if (and cell table-detect-cell-alignment)
1953 (table--detect-cell-alignment cell)))
1954 (unless (re-search-forward border end t)
1955 (goto-char end))))))))))
1956 (restore-buffer-modified-p modified-flag)))
1958 ;;;###autoload
1959 (defun table-unrecognize-region (beg end)
1960 (interactive "r")
1961 (table-recognize-region beg end -1))
1963 ;;;###autoload
1964 (defun table-recognize-table (&optional arg)
1965 "Recognize a table at point.
1966 If the optional numeric prefix argument ARG is negative the table
1967 becomes inactive, meaning the table becomes plain text and loses all
1968 the table specific features."
1969 (interactive "P")
1970 (setq arg (prefix-numeric-value arg))
1971 (let ((unrecognize (< arg 0))
1972 (origin-cell (table--probe-cell))
1973 (inhibit-read-only t))
1974 (if origin-cell
1975 (save-excursion
1976 (while
1977 (progn
1978 (table-forward-cell 1 nil unrecognize)
1979 (let ((cell (table--probe-cell)))
1980 (if (and cell table-detect-cell-alignment)
1981 (table--detect-cell-alignment cell))
1982 (and cell (not (equal cell origin-cell))))))))))
1984 ;;;###autoload
1985 (defun table-unrecognize-table ()
1986 (interactive)
1987 (table-recognize-table -1))
1989 ;;;###autoload
1990 (defun table-recognize-cell (&optional force no-copy arg)
1991 "Recognize a table cell that contains current point.
1992 Probe the cell dimension and prepare the cell information. The
1993 optional two arguments FORCE and NO-COPY are for internal use only and
1994 must not be specified. When the optional numeric prefix argument ARG
1995 is negative the cell becomes inactive, meaning that the cell becomes
1996 plain text and loses all the table specific features."
1997 (interactive "i\ni\np")
1998 (table--make-cell-map)
1999 (if (or force (not (memq (table--get-last-command) table-command-list)))
2000 (let* ((cell (table--probe-cell (called-interactively-p 'interactive)))
2001 (cache-buffer (get-buffer-create table-cache-buffer-name))
2002 (modified-flag (buffer-modified-p))
2003 (inhibit-read-only t))
2004 (unwind-protect
2005 (unless (null cell)
2006 ;; initialize the cell info variables
2007 (let ((lu-coordinate (table--get-coordinate (car cell)))
2008 (rb-coordinate (table--get-coordinate (cdr cell))))
2009 ;; update the previous cell if this cell is different from the previous one.
2010 ;; care only lu but ignore rb since size change does not matter.
2011 (unless (equal table-cell-info-lu-coordinate lu-coordinate)
2012 (table--finish-delayed-tasks))
2013 (setq table-cell-info-lu-coordinate lu-coordinate)
2014 (setq table-cell-info-rb-coordinate rb-coordinate)
2015 (setq table-cell-info-width (- (car table-cell-info-rb-coordinate)
2016 (car table-cell-info-lu-coordinate)))
2017 (setq table-cell-info-height (+ (- (cdr table-cell-info-rb-coordinate)
2018 (cdr table-cell-info-lu-coordinate)) 1))
2019 (setq table-cell-info-justify (table--get-cell-justify-property cell))
2020 (setq table-cell-info-valign (table--get-cell-valign-property cell)))
2021 ;; set/remove table cell properties
2022 (if (< (prefix-numeric-value arg) 0)
2023 (let ((coord (table--get-coordinate (car cell)))
2024 (n table-cell-info-height))
2025 (save-excursion
2026 (while (> n 0)
2027 (table--remove-cell-properties
2028 (table--goto-coordinate coord)
2029 (table--goto-coordinate (cons (+ (car coord) table-cell-info-width 1) (cdr coord))))
2030 (setq n (1- n))
2031 (setcdr coord (1+ (cdr coord))))))
2032 (table--put-cell-property cell))
2033 ;; copy the cell contents to the cache buffer
2034 ;; only if no-copy is nil and timers are not set
2035 (unless no-copy
2036 (setq table-cell-cache-point-coordinate (table--transcoord-table-to-cache))
2037 (setq table-cell-cache-mark-coordinate (table--transcoord-table-to-cache
2038 (table--get-coordinate (marker-position (mark-marker)))))
2039 (setq table-cell-buffer (current-buffer))
2040 (let ((rectangle (extract-rectangle (car cell)
2041 (cdr cell))))
2042 (save-current-buffer
2043 (set-buffer cache-buffer)
2044 (erase-buffer)
2045 (table--insert-rectangle rectangle)))))
2046 (restore-buffer-modified-p modified-flag))
2047 (if (featurep 'xemacs)
2048 (table--warn-incompatibility))
2049 cell)))
2051 ;;;###autoload
2052 (defun table-unrecognize-cell ()
2053 (interactive)
2054 (table-recognize-cell nil nil -1))
2056 ;;;###autoload
2057 (defun table-heighten-cell (n &optional no-copy no-update)
2058 "Heighten the current cell by N lines by expanding the cell vertically.
2059 Heightening is done by adding blank lines at the bottom of the current
2060 cell. Other cells aligned horizontally with the current one are also
2061 heightened in order to keep the rectangular table structure. The
2062 optional argument NO-COPY is internal use only and must not be
2063 specified."
2064 (interactive "*p")
2065 (if (< n 0) (setq n 1))
2066 (let* ((coord-list (table--cell-list-to-coord-list (table--horizontal-cell-list t)))
2067 (left-list nil)
2068 (this-list coord-list)
2069 (right-list (cdr coord-list))
2070 (bottom-border-y (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))
2071 (vertical-str (string table-cell-vertical-char))
2072 (vertical-str-with-properties (string table-cell-vertical-char))
2073 (first-time t)
2074 (current-coordinate (table--get-coordinate)))
2075 ;; prepare the right vertical string with appropriate properties put
2076 (table--put-cell-keymap-property 0 (length vertical-str-with-properties) vertical-str-with-properties)
2077 ;; create the space below for the table to grow
2078 (table--create-growing-space-below n coord-list bottom-border-y)
2079 ;; vertically expand each cell from left to right
2080 (while this-list
2081 (let* ((left (prog1 (car left-list) (setq left-list (if left-list (cdr left-list) coord-list))))
2082 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
2083 (right (prog1 (car right-list) (setq right-list (cdr right-list))))
2084 (exclude-left (and left (< (cddr left) (cddr this))))
2085 (exclude-right (and right (<= (cddr right) (cddr this))))
2086 (beg (table--goto-coordinate
2087 (cons (if exclude-left (caar this) (1- (caar this)))
2088 (1+ (cddr this)))))
2089 (end (table--goto-coordinate
2090 (cons (if exclude-right (cadr this) (1+ (cadr this)))
2091 bottom-border-y)))
2092 (rect (extract-rectangle beg end)))
2093 ;; prepend blank cell lines to the extracted rectangle
2094 (let ((i n))
2095 (while (> i 0)
2096 (setq rect (cons
2097 (concat (if exclude-left ""
2098 (if first-time vertical-str vertical-str-with-properties))
2099 (table--cell-blank-str (- (cadr this) (caar this)))
2100 (if exclude-right "" vertical-str-with-properties))
2101 rect))
2102 (setq i (1- i))))
2103 (setq first-time nil)
2104 (delete-rectangle beg end)
2105 (goto-char beg)
2106 (table--insert-rectangle rect)))
2107 (table--goto-coordinate current-coordinate)
2108 ;; re-recognize the current cell's new dimension
2109 (table-recognize-cell 'force no-copy)
2110 (unless no-update
2111 (table--update-cell-heightened))))
2113 ;;;###autoload
2114 (defun table-shorten-cell (n)
2115 "Shorten the current cell by N lines by shrinking the cell vertically.
2116 Shortening is done by removing blank lines from the bottom of the cell
2117 and possibly from the top of the cell as well. Therefore, the cell
2118 must have some bottom/top blank lines to be shorten effectively. This
2119 is applicable to all the cells aligned horizontally with the current
2120 one because they are also shortened in order to keep the rectangular
2121 table structure."
2122 (interactive "*p")
2123 (if (< n 0) (setq n 1))
2124 (table--finish-delayed-tasks)
2125 (let* ((table-inhibit-update t)
2126 (coord-list (table--cell-list-to-coord-list (table--horizontal-cell-list t)))
2127 (left-list nil)
2128 (this-list coord-list)
2129 (right-list (cdr coord-list))
2130 (bottom-budget-list nil)
2131 (bottom-border-y (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))
2132 (current-coordinate (table--get-coordinate))
2133 (current-cell-coordinate (table--cell-to-coord (table--probe-cell)))
2134 (blank-line-regexp "\\s *$"))
2135 (message "Shortening...");; this operation may be lengthy
2136 ;; for each cell calculate the maximum number of blank lines we can delete
2137 ;; and adjust the argument n. n is adjusted so that the total number of
2138 ;; blank lines from top and bottom of a cell do not exceed n, all cell has
2139 ;; at least one line height after blank line deletion.
2140 (while this-list
2141 (let ((this (prog1 (car this-list) (setq this-list (cdr this-list)))))
2142 (table--goto-coordinate (car this))
2143 (table-recognize-cell 'force)
2144 (table-with-cache-buffer
2145 (catch 'end-count
2146 (let ((blank-line-count 0))
2147 (table--goto-coordinate (cons 0 (1- table-cell-info-height)))
2148 ;; count bottom
2149 (while (and (looking-at blank-line-regexp)
2150 (setq blank-line-count (1+ blank-line-count))
2151 ;; need to leave at least one blank line
2152 (if (> blank-line-count n) (throw 'end-count nil) t)
2153 (if (zerop (forward-line -1)) t
2154 (setq n (if (zerop blank-line-count) 0
2155 (1- blank-line-count)))
2156 (throw 'end-count nil))))
2157 (table--goto-coordinate (cons 0 0))
2158 ;; count top
2159 (while (and (looking-at blank-line-regexp)
2160 (setq blank-line-count (1+ blank-line-count))
2161 ;; can consume all blank lines
2162 (if (>= blank-line-count n) (throw 'end-count nil) t)
2163 (zerop (forward-line 1))))
2164 (setq n blank-line-count))))))
2165 ;; construct the bottom-budget-list which is a list of numbers where each number
2166 ;; corresponds to how many lines to be deleted from the bottom of each cell. If
2167 ;; this number, say bb, is smaller than n (bb < n) that means the difference (n - bb)
2168 ;; number of lines must be deleted from the top of the cell in addition to deleting
2169 ;; bb lines from the bottom of the cell.
2170 (setq this-list coord-list)
2171 (while this-list
2172 (let ((this (prog1 (car this-list) (setq this-list (cdr this-list)))))
2173 (table--goto-coordinate (car this))
2174 (table-recognize-cell 'force)
2175 (table-with-cache-buffer
2176 (setq bottom-budget-list
2177 (cons
2178 (let ((blank-line-count 0))
2179 (table--goto-coordinate (cons 0 (1- table-cell-info-height)))
2180 (while (and (looking-at blank-line-regexp)
2181 (< blank-line-count n)
2182 (setq blank-line-count (1+ blank-line-count))
2183 (zerop (forward-line -1))))
2184 blank-line-count)
2185 bottom-budget-list)))))
2186 (setq bottom-budget-list (nreverse bottom-budget-list))
2187 ;; vertically shorten each cell from left to right
2188 (setq this-list coord-list)
2189 (while this-list
2190 (let* ((left (prog1 (car left-list) (setq left-list (if left-list (cdr left-list) coord-list))))
2191 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
2192 (right (prog1 (car right-list) (setq right-list (cdr right-list))))
2193 (bottom-budget (prog1 (car bottom-budget-list) (setq bottom-budget-list (cdr bottom-budget-list))))
2194 (exclude-left (and left (< (cddr left) (cddr this))))
2195 (exclude-right (and right (<= (cddr right) (cddr this))))
2196 (beg (table--goto-coordinate (cons (caar this) (cdar this))))
2197 (end (table--goto-coordinate (cons (cadr this) bottom-border-y)))
2198 (rect (extract-rectangle beg end))
2199 (height (+ (- (cddr this) (cdar this)) 1))
2200 (blank-line (make-string (- (cadr this) (caar this)) ?\s)))
2201 ;; delete lines from the bottom of the cell
2202 (setcdr (nthcdr (- height bottom-budget 1) rect) (nthcdr height rect))
2203 ;; delete lines from the top of the cell
2204 (if (> n bottom-budget)
2205 (let ((props (text-properties-at 0 (car rect))))
2206 (setq rect (nthcdr (- n bottom-budget) rect))
2207 (set-text-properties 0 1 props (car rect))))
2208 ;; append blank lines below the table
2209 (setq rect (append rect (make-list n blank-line)))
2210 ;; now swap the area with the prepared rect of the same size
2211 (delete-rectangle beg end)
2212 (goto-char beg)
2213 (table--insert-rectangle rect)
2214 ;; for the left and right borders always delete lines from the bottom of the cell
2215 (unless exclude-left
2216 (let* ((beg (table--goto-coordinate (cons (1- (caar this)) (cdar this))))
2217 (end (table--goto-coordinate (cons (caar this) bottom-border-y)))
2218 (rect (extract-rectangle beg end)))
2219 (setcdr (nthcdr (- height n 1) rect) (nthcdr height rect))
2220 (setq rect (append rect (make-list n " ")))
2221 (delete-rectangle beg end)
2222 (goto-char beg)
2223 (table--insert-rectangle rect)))
2224 (unless exclude-right
2225 (let* ((beg (table--goto-coordinate (cons (cadr this) (cdar this))))
2226 (end (table--goto-coordinate (cons (1+ (cadr this)) bottom-border-y)))
2227 (rect (extract-rectangle beg end)))
2228 (setcdr (nthcdr (- height n 1) rect) (nthcdr height rect))
2229 (setq rect (append rect (make-list n " ")))
2230 (delete-rectangle beg end)
2231 (goto-char beg)
2232 (table--insert-rectangle rect)))
2233 ;; if this is the cell where the original point was in, adjust the point location
2234 (if (null (equal this current-cell-coordinate)) nil
2235 (let ((y (- (cdr current-coordinate) (cdar this))))
2236 (if (< y (- n bottom-budget))
2237 (setcdr current-coordinate (cdar this))
2238 (if (< (- y (- n bottom-budget)) (- height n))
2239 (setcdr current-coordinate (+ (cdar this) (- y (- n bottom-budget))))
2240 (setcdr current-coordinate (+ (cdar this) (- height n 1)))))))))
2241 ;; remove the appended blank lines below the table if they are unnecessary
2242 (table--goto-coordinate (cons 0 (1+ (- bottom-border-y n))))
2243 (table--remove-blank-lines n)
2244 ;; re-recognize the current cell's new dimension
2245 (table--goto-coordinate current-coordinate)
2246 (table-recognize-cell 'force)
2247 (table--update-cell-heightened)
2248 (message "")))
2250 ;;;###autoload
2251 (defun table-widen-cell (n &optional no-copy no-update)
2252 "Widen the current cell by N columns and expand the cell horizontally.
2253 Some other cells in the same table are widen as well to keep the
2254 table's rectangle structure."
2255 (interactive "*p")
2256 (if (< n 0) (setq n 1))
2257 (let* ((coord-list (table--cell-list-to-coord-list (table--vertical-cell-list)))
2258 (below-list nil)
2259 (this-list coord-list)
2260 (above-list (cdr coord-list)))
2261 (save-excursion
2262 ;; push back the affected area above and below this table
2263 (table--horizontally-shift-above-and-below n (reverse coord-list))
2264 ;; now widen vertically for each cell
2265 (while this-list
2266 (let* ((below (prog1 (car below-list) (setq below-list (if below-list (cdr below-list) coord-list))))
2267 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
2268 (above (prog1 (car above-list) (setq above-list (cdr above-list))))
2269 (beg (table--goto-coordinate
2270 (cons (car (cdr this))
2271 (if (or (null above) (<= (car (cdr this)) (car (cdr above))))
2272 (1- (cdr (car this)))
2273 (cdr (car this))))))
2274 (end (table--goto-coordinate
2275 (cons (1+ (car (cdr this)))
2276 (if (or (null below) (< (car (cdr this)) (car (cdr below))))
2277 (1+ (cdr (cdr this)))
2278 (cdr (cdr this))))))
2279 (tmp (extract-rectangle (1- beg) end))
2280 (border (format "[%s%c]\\%c"
2281 table-cell-horizontal-chars
2282 table-cell-intersection-char
2283 table-cell-intersection-char))
2284 (blank (table--cell-blank-str))
2285 rectangle)
2286 ;; create a single wide vertical bar of empty cell fragment
2287 (while tmp
2288 ; (message "tmp is %s" tmp)
2289 (setq rectangle (cons
2290 (if (string-match border (car tmp))
2291 (substring (car tmp) 0 1)
2292 blank)
2293 rectangle))
2294 ; (message "rectangle is %s" rectangle)
2295 (setq tmp (cdr tmp)))
2296 (setq rectangle (nreverse rectangle))
2297 ;; untabify the area right of the bar that is about to be inserted
2298 (let ((coord (table--get-coordinate beg))
2299 (i 0)
2300 (len (length rectangle)))
2301 (while (< i len)
2302 (if (table--goto-coordinate coord 'no-extension)
2303 (table--untabify-line (point)))
2304 (setcdr coord (1+ (cdr coord)))
2305 (setq i (1+ i))))
2306 ;; insert the bar n times
2307 (goto-char beg)
2308 (let ((i 0))
2309 (while (< i n)
2310 (save-excursion
2311 (table--insert-rectangle rectangle))
2312 (setq i (1+ i)))))))
2313 (table-recognize-cell 'force no-copy)
2314 (unless no-update
2315 (table--update-cell-widened))))
2317 ;;;###autoload
2318 (defun table-narrow-cell (n)
2319 "Narrow the current cell by N columns and shrink the cell horizontally.
2320 Some other cells in the same table are narrowed as well to keep the
2321 table's rectangle structure."
2322 (interactive "*p")
2323 (if (< n 0) (setq n 1))
2324 (table--finish-delayed-tasks)
2325 (let* ((coord-list (table--cell-list-to-coord-list (table--vertical-cell-list)))
2326 (current-cell (table--cell-to-coord (table--probe-cell)))
2327 (current-coordinate (table--get-coordinate))
2328 tmp-list)
2329 (message "Narrowing...");; this operation may be lengthy
2330 ;; determine the doable n by try narrowing each cell.
2331 (setq tmp-list coord-list)
2332 (while tmp-list
2333 (let ((cell (prog1 (car tmp-list) (setq tmp-list (cdr tmp-list))))
2334 (table-inhibit-update t)
2335 cell-n)
2336 (table--goto-coordinate (car cell))
2337 (table-recognize-cell 'force)
2338 (table-with-cache-buffer
2339 (table--fill-region (point-min) (point-max) (- table-cell-info-width n))
2340 (if (< (setq cell-n (- table-cell-info-width (table--measure-max-width))) n)
2341 (setq n cell-n))
2342 (erase-buffer)
2343 (setq table-inhibit-auto-fill-paragraph t))))
2344 (if (< n 1) nil
2345 ;; narrow only the contents of each cell but leave the cell frame as is because
2346 ;; we need to have valid frame structure in order for table-with-cache-buffer
2347 ;; to work correctly.
2348 (setq tmp-list coord-list)
2349 (while tmp-list
2350 (let* ((cell (prog1 (car tmp-list) (setq tmp-list (cdr tmp-list))))
2351 (table-inhibit-update t)
2352 (currentp (equal cell current-cell))
2353 old-height)
2354 (if currentp (table--goto-coordinate current-coordinate)
2355 (table--goto-coordinate (car cell)))
2356 (table-recognize-cell 'force)
2357 (setq old-height table-cell-info-height)
2358 (table-with-cache-buffer
2359 (let ((out-of-bound (>= (- (car current-coordinate) (car table-cell-info-lu-coordinate))
2360 (- table-cell-info-width n)))
2361 (sticky (and currentp
2362 (save-excursion
2363 (unless (bolp) (forward-char -1))
2364 (looking-at ".*\\S ")))))
2365 (table--fill-region (point-min) (point-max) (- table-cell-info-width n))
2366 (if (or sticky (and currentp (looking-at ".*\\S ")))
2367 (setq current-coordinate (table--transcoord-cache-to-table))
2368 (if out-of-bound (setcar current-coordinate
2369 (+ (car table-cell-info-lu-coordinate) (- table-cell-info-width n 1))))))
2370 (setq table-inhibit-auto-fill-paragraph t))
2371 (table--update-cell 'now)
2372 ;; if this cell heightens and pushes the current cell below, move
2373 ;; the current-coordinate (point location) down accordingly.
2374 (if currentp (setq current-coordinate (table--get-coordinate))
2375 (if (and (> table-cell-info-height old-height)
2376 (> (cdr current-coordinate) (cdr table-cell-info-lu-coordinate)))
2377 (setcdr current-coordinate (+ (cdr current-coordinate)
2378 (- table-cell-info-height old-height)))))
2380 ;; coord-list is now possibly invalid since some cells may have already
2381 ;; been heightened so recompute them by table--vertical-cell-list.
2382 (table--goto-coordinate current-coordinate)
2383 (setq coord-list (table--cell-list-to-coord-list (table--vertical-cell-list)))
2384 ;; push in the affected area above and below this table so that things
2385 ;; on the right side of the table are shifted horizontally neatly.
2386 (table--horizontally-shift-above-and-below (- n) (reverse coord-list))
2387 ;; finally narrow the frames for each cell.
2388 (let* ((below-list nil)
2389 (this-list coord-list)
2390 (above-list (cdr coord-list)))
2391 (while this-list
2392 (let* ((below (prog1 (car below-list) (setq below-list (if below-list (cdr below-list) coord-list))))
2393 (this (prog1 (car this-list) (setq this-list (cdr this-list))))
2394 (above (prog1 (car above-list) (setq above-list (cdr above-list)))))
2395 (delete-rectangle
2396 (table--goto-coordinate
2397 (cons (- (cadr this) n)
2398 (if (or (null above) (<= (cadr this) (cadr above)))
2399 (1- (cdar this))
2400 (cdar this))))
2401 (table--goto-coordinate
2402 (cons (cadr this)
2403 (if (or (null below) (< (cadr this) (cadr below)))
2404 (1+ (cddr this))
2405 (cddr this)))))))))
2406 (table--goto-coordinate current-coordinate)
2407 ;; re-recognize the current cell's new dimension
2408 (table-recognize-cell 'force)
2409 (message "")))
2411 ;;;###autoload
2412 (defun table-forward-cell (&optional arg no-recognize unrecognize)
2413 "Move point forward to the beginning of the next cell.
2414 With argument ARG, do it ARG times;
2415 a negative argument ARG = -N means move backward N cells.
2416 Do not specify NO-RECOGNIZE and UNRECOGNIZE. They are for internal use only.
2418 Sample Cell Traveling Order (In Irregular Table Cases)
2420 You can actually try how it works in this buffer. Press
2421 \\[table-recognize] and go to cells in the following tables and press
2422 \\[table-forward-cell] or TAB key.
2424 +-----+--+ +--+-----+ +--+--+--+ +--+--+--+ +---------+ +--+---+--+
2425 |0 |1 | |0 |1 | |0 |1 |2 | |0 |1 |2 | |0 | |0 |1 |2 |
2426 +--+--+ | | +--+--+ +--+ | | | | +--+ +----+----+ +--+-+-+--+
2427 |2 |3 | | | |2 |3 | |3 +--+ | | +--+3 | |1 |2 | |3 |4 |
2428 | +--+--+ +--+--+ | +--+4 | | | |4 +--+ +--+-+-+--+ +----+----+
2429 | |4 | |4 | | |5 | | | | | |5 | |3 |4 |5 | |5 |
2430 +--+-----+ +-----+--+ +--+--+--+ +--+--+--+ +--+---+--+ +---------+
2432 +--+--+--+ +--+--+--+ +--+--+--+ +--+--+--+
2433 |0 |1 |2 | |0 |1 |2 | |0 |1 |2 | |0 |1 |2 |
2434 | | | | | +--+ | | | | | +--+ +--+
2435 +--+ +--+ +--+3 +--+ | +--+ | |3 +--+4 |
2436 |3 | |4 | |4 +--+5 | | |3 | | +--+5 +--+
2437 | | | | | |6 | | | | | | |6 | |7 |
2438 +--+--+--+ +--+--+--+ +--+--+--+ +--+--+--+
2440 +--+--+--+ +--+--+--+ +--+--+--+--+ +--+-----+--+ +--+--+--+--+
2441 |0 |1 |2 | |0 |1 |2 | |0 |1 |2 |3 | |0 |1 |2 | |0 |1 |2 |3 |
2442 | +--+ | | +--+ | | +--+--+ | | | | | | +--+--+ |
2443 | |3 +--+ +--+3 | | +--+4 +--+ +--+ +--+ +--+4 +--+
2444 +--+ |4 | |4 | +--+ |5 +--+--+6 | |3 +--+--+4 | |5 | |6 |
2445 |5 +--+ | | +--+5 | | |7 |8 | | | |5 |6 | | | | | |
2446 | |6 | | | |6 | | +--+--+--+--+ +--+--+--+--+ +--+-----+--+
2447 +--+--+--+ +--+--+--+
2449 ;; After modifying this function, test against the above tables in
2450 ;; the doc string. It is quite tricky. The tables above do not
2451 ;; mean to cover every possible cases of cell layout, of course.
2452 ;; They are examples of tricky cases from implementation point of
2453 ;; view and provided for simple regression test purpose.
2454 (interactive "p")
2455 (or arg (setq arg 1))
2456 (table--finish-delayed-tasks)
2457 (while (null (zerop arg))
2458 (let* ((pivot (table--probe-cell 'abort-on-error))
2459 (cell pivot) edge tip)
2460 ;; go to the beginning of the first right/left cell with same height if exists
2461 (while (and (setq cell (table--goto-coordinate
2462 (cons (if (> arg 0) (1+ (car (table--get-coordinate (cdr cell))))
2463 (1- (car (table--get-coordinate (car cell)))))
2464 (cdr (table--get-coordinate (car pivot)))) 'no-extension))
2465 (setq cell (table--probe-cell))
2466 (/= (cdr (table--get-coordinate (car cell)))
2467 (cdr (table--get-coordinate (car pivot))))))
2468 (if cell (goto-char (car cell)) ; done
2469 ;; if the horizontal move fails search the most left/right edge cell below/above the pivot
2470 ;; but first find the edge cell
2471 (setq edge pivot)
2472 (while (and (table--goto-coordinate
2473 (cons (if (> arg 0) (1- (car (table--get-coordinate (car edge))))
2474 (1+ (car (table--get-coordinate (cdr edge)))))
2475 (cdr (table--get-coordinate (car pivot)))) 'no-extension)
2476 (setq cell (table--probe-cell))
2477 (setq edge cell)))
2478 (setq cell (if (> arg 0) edge
2479 (or (and (table--goto-coordinate
2480 (cons (car (table--get-coordinate (cdr edge)))
2481 (1- (cdr (table--get-coordinate (car edge))))))
2482 (table--probe-cell))
2483 edge)))
2484 ;; now search for the tip which is the highest/lowest below/above cell
2485 (while cell
2486 (let (below/above)
2487 (and (table--goto-coordinate
2488 (cons (car (table--get-coordinate (if (> arg 0) (car cell)
2489 (cdr cell))))
2490 (if (> arg 0) (+ 2 (cdr (table--get-coordinate (cdr cell))))
2491 (1- (cdr (table--get-coordinate (car pivot)))))) 'no-extension)
2492 (setq below/above (table--probe-cell))
2493 (or (null tip)
2494 (if (> arg 0)
2495 (< (cdr (table--get-coordinate (car below/above)))
2496 (cdr (table--get-coordinate (car tip))))
2497 (> (cdr (table--get-coordinate (car below/above)))
2498 (cdr (table--get-coordinate (car tip))))))
2499 (setq tip below/above)))
2500 (and (setq cell (table--goto-coordinate
2501 (cons (if (> arg 0) (1+ (car (table--get-coordinate (cdr cell))))
2502 (1- (car (table--get-coordinate (car cell)))))
2503 (if (> arg 0) (cdr (table--get-coordinate (car pivot)))
2504 (1- (cdr (table--get-coordinate (car pivot)))))) 'no-extension))
2505 (setq cell (table--probe-cell))))
2506 (if tip (goto-char (car tip)) ; done
2507 ;; let's climb up/down to the top/bottom from the edge
2508 (while (and (table--goto-coordinate
2509 (cons (if (> arg 0) (car (table--get-coordinate (car edge)))
2510 (car (table--get-coordinate (cdr edge))))
2511 (if (> arg 0) (1- (cdr (table--get-coordinate (car edge))))
2512 (+ 2 (cdr (table--get-coordinate (cdr edge)))))) 'no-extension)
2513 (setq cell (table--probe-cell))
2514 (setq edge cell)))
2515 (if (< arg 0)
2516 (progn
2517 (setq cell edge)
2518 (while (and (table--goto-coordinate
2519 (cons (1- (car (table--get-coordinate (car cell))))
2520 (cdr (table--get-coordinate (cdr cell)))) 'no-extension)
2521 (setq cell (table--probe-cell)))
2522 (if (> (cdr (table--get-coordinate (car cell)))
2523 (cdr (table--get-coordinate (car edge))))
2524 (setq edge cell)))))
2525 (goto-char (car edge))))) ; the top left cell
2526 (setq arg (if (> arg 0) (1- arg) (1+ arg))))
2527 (unless no-recognize
2528 (table-recognize-cell 'force nil (if unrecognize -1 nil)))) ; refill the cache with new cell contents
2530 ;;;###autoload
2531 (defun table-backward-cell (&optional arg)
2532 "Move backward to the beginning of the previous cell.
2533 With argument ARG, do it ARG times;
2534 a negative argument ARG = -N means move forward N cells."
2535 (interactive "p")
2536 (or arg (setq arg 1))
2537 (table-forward-cell (- arg)))
2539 ;;;###autoload
2540 (defun table-span-cell (direction)
2541 "Span current cell into adjacent cell in DIRECTION.
2542 DIRECTION is one of symbols; right, left, above or below."
2543 (interactive
2544 (list
2545 (let* ((_ (barf-if-buffer-read-only))
2546 (direction-list
2547 (let* ((tmp (delete nil
2548 (mapcar (lambda (d)
2549 (if (table--cell-can-span-p d)
2550 (list (symbol-name d))))
2551 '(right left above below)))))
2552 (if (null tmp)
2553 (error "Can't span this cell"))
2554 tmp))
2555 (default-direction (if (member (list (car table-cell-span-direction-history)) direction-list)
2556 (car table-cell-span-direction-history)
2557 (caar direction-list)))
2558 (completion-ignore-case t))
2559 (intern (downcase (completing-read
2560 (format "Span into (default %s): " default-direction)
2561 direction-list
2562 nil t nil 'table-cell-span-direction-history default-direction))))))
2563 (unless (memq direction '(right left above below))
2564 (error "Invalid direction %s, must be right, left, above or below"
2565 (symbol-name direction)))
2566 (table-recognize-cell 'force)
2567 (unless (table--cell-can-span-p direction)
2568 (error "Can't span %s" (symbol-name direction)))
2569 ;; Prepare beginning and end positions of the border bar to strike through.
2570 (let ((beg (save-excursion
2571 (table--goto-coordinate
2572 (cond
2573 ((eq direction 'right)
2574 (cons (car table-cell-info-rb-coordinate)
2575 (1- (cdr table-cell-info-lu-coordinate))))
2576 ((eq direction 'below)
2577 (cons (1- (car table-cell-info-lu-coordinate))
2578 (1+ (cdr table-cell-info-rb-coordinate))))
2580 (cons (1- (car table-cell-info-lu-coordinate))
2581 (1- (cdr table-cell-info-lu-coordinate)))))
2582 'no-extension)))
2583 (end (save-excursion
2584 (table--goto-coordinate
2585 (cond
2586 ((eq direction 'left)
2587 (cons (car table-cell-info-lu-coordinate)
2588 (1+ (cdr table-cell-info-rb-coordinate))))
2589 ((eq direction 'above)
2590 (cons (1+ (car table-cell-info-rb-coordinate))
2591 (1- (cdr table-cell-info-lu-coordinate))))
2593 (cons (1+ (car table-cell-info-rb-coordinate))
2594 (1+ (cdr table-cell-info-rb-coordinate)))))
2595 'no-extension))))
2596 ;; Replace the bar with blank space while taking care of edges to be border
2597 ;; or intersection.
2598 (save-excursion
2599 (goto-char beg)
2600 (if (memq direction '(left right))
2601 (let* ((column (current-column))
2602 rectangle
2603 (n-element (- (length (extract-rectangle beg end)) 2))
2604 (above-contp (and (goto-char beg)
2605 (zerop (forward-line -1))
2606 (= (move-to-column column) column)
2607 (looking-at (regexp-quote (char-to-string table-cell-vertical-char)))))
2608 (below-contp (and (goto-char end)
2609 (progn (forward-char -1) t)
2610 (zerop (forward-line 1))
2611 (= (move-to-column column) column)
2612 (looking-at (regexp-quote (char-to-string table-cell-vertical-char))))))
2613 (setq rectangle
2614 (cons (if below-contp
2615 (char-to-string table-cell-intersection-char)
2616 (substring table-cell-horizontal-chars 0 1))
2617 rectangle))
2618 (while (> n-element 0)
2619 (setq rectangle (cons (table--cell-blank-str 1) rectangle))
2620 (setq n-element (1- n-element)))
2621 (setq rectangle
2622 (cons (if above-contp
2623 (char-to-string table-cell-intersection-char)
2624 (substring table-cell-horizontal-chars 0 1))
2625 rectangle))
2626 (delete-rectangle beg end)
2627 (goto-char beg)
2628 (table--insert-rectangle rectangle))
2629 (delete-region beg end)
2630 (insert (if (and (> (point) (point-min))
2631 (save-excursion
2632 (forward-char -1)
2633 (looking-at (regexp-opt-charset
2634 (string-to-list table-cell-horizontal-chars)))))
2635 table-cell-intersection-char
2636 table-cell-vertical-char)
2637 (table--cell-blank-str (- end beg 2))
2638 (if (looking-at (regexp-opt-charset
2639 (string-to-list table-cell-horizontal-chars)))
2640 table-cell-intersection-char
2641 table-cell-vertical-char))))
2642 ;; recognize the newly created spanned cell
2643 (table-recognize-cell 'force)
2644 (if (member direction '(right left))
2645 (table-with-cache-buffer
2646 (table--fill-region (point-min) (point-max))
2647 (setq table-inhibit-auto-fill-paragraph t)))))
2649 ;;;###autoload
2650 (defun table-split-cell-vertically ()
2651 "Split current cell vertically.
2652 Creates a cell above and a cell below the current point location."
2653 (interactive "*")
2654 (table-recognize-cell 'force)
2655 (let ((point-y (cdr (table--get-coordinate))))
2656 (unless (table--cell-can-split-vertically-p)
2657 (error "Can't split here"))
2658 (let* ((old-coordinate (table--get-coordinate))
2659 (column (current-column))
2660 (beg (table--goto-coordinate
2661 (cons (1- (car table-cell-info-lu-coordinate))
2662 point-y)))
2663 (end (table--goto-coordinate
2664 (cons (1+ (car table-cell-info-rb-coordinate))
2665 point-y)))
2666 (line (buffer-substring (1+ beg) (1- end))))
2667 (when (= (cdr old-coordinate) (cdr table-cell-info-rb-coordinate))
2668 (table--goto-coordinate old-coordinate)
2669 (table-heighten-cell 1 'no-copy 'no-update))
2670 (goto-char beg)
2671 (delete-region beg end)
2672 (insert table-cell-intersection-char
2673 (make-string table-cell-info-width (string-to-char table-cell-horizontal-chars))
2674 table-cell-intersection-char)
2675 (table--goto-coordinate old-coordinate)
2676 (forward-line 1)
2677 (move-to-column column)
2678 (setq old-coordinate (table--get-coordinate))
2679 (table-recognize-cell 'force)
2680 (unless (string-match "^\\s *$" line)
2681 (table-with-cache-buffer
2682 (goto-char (point-min))
2683 (insert line ?\n)
2684 (goto-char (point-min)) ;; don't heighten cell unnecessarily
2685 (setq table-inhibit-auto-fill-paragraph t)))
2686 (table--update-cell 'now) ;; can't defer this operation
2687 (table--goto-coordinate old-coordinate)
2688 (move-to-column column)
2689 (table-recognize-cell 'force))))
2691 ;;;###autoload
2692 (defun table-split-cell-horizontally ()
2693 "Split current cell horizontally.
2694 Creates a cell on the left and a cell on the right of the current point location."
2695 (interactive "*")
2696 (table-recognize-cell 'force)
2697 (let* ((o-coordinate (table--get-coordinate))
2698 (point-x (car o-coordinate))
2699 cell-empty cell-contents cell-coordinate
2700 contents-to beg end rectangle strip-rect
2701 (right-edge (= (car o-coordinate) (1- (car table-cell-info-rb-coordinate)))))
2702 (unless (table--cell-can-split-horizontally-p)
2703 (error "Can't split here"))
2704 (let ((table-inhibit-update t))
2705 (table-with-cache-buffer
2706 (setq cell-coordinate (table--get-coordinate))
2707 (save-excursion
2708 (goto-char (point-min))
2709 (setq cell-empty (null (re-search-forward "\\S " nil t))))
2710 (setq cell-contents (buffer-substring (point-min) (point-max)))
2711 (setq table-inhibit-auto-fill-paragraph t)))
2712 (setq contents-to
2713 (if cell-empty 'left
2714 (let* ((completion-ignore-case t)
2715 (default (car table-cell-split-contents-to-history)))
2716 (intern
2717 (if (member 'click (event-modifiers last-input-event))
2718 (x-popup-menu last-input-event
2719 '("Existing cell contents to:"
2720 ("Title"
2721 ("Split" . "split") ("Left" . "left") ("Right" . "right"))))
2722 (downcase (completing-read
2723 (format "Existing cell contents to (default %s): " default)
2724 '(("split") ("left") ("right"))
2725 nil t nil 'table-cell-split-contents-to-history default)))))))
2726 (unless (eq contents-to 'split)
2727 (table-with-cache-buffer
2728 (erase-buffer)
2729 (setq table-inhibit-auto-fill-paragraph t)))
2730 (table--update-cell 'now)
2731 (setq beg (table--goto-coordinate
2732 (cons point-x
2733 (1- (cdr table-cell-info-lu-coordinate)))))
2734 (setq end (table--goto-coordinate
2735 (cons (1+ point-x)
2736 (1+ (cdr table-cell-info-rb-coordinate)))))
2737 (setq rectangle (cons (char-to-string table-cell-intersection-char) nil))
2738 (let ((n table-cell-info-height))
2739 (while (prog1 (> n 0) (setq n (1- n)))
2740 (setq rectangle (cons (char-to-string table-cell-vertical-char) rectangle))))
2741 (setq rectangle (cons (char-to-string table-cell-intersection-char) rectangle))
2742 (if (eq contents-to 'split)
2743 (setq strip-rect (extract-rectangle beg end)))
2744 (delete-rectangle beg end)
2745 (goto-char beg)
2746 (table--insert-rectangle rectangle)
2747 (table--goto-coordinate o-coordinate)
2748 (if cell-empty
2749 (progn
2750 (forward-char 1)
2751 (if right-edge
2752 (table-widen-cell 1)))
2753 (unless (eq contents-to 'left)
2754 (forward-char 1))
2755 (table-recognize-cell 'force)
2756 (table-with-cache-buffer
2757 (if (eq contents-to 'split)
2758 ;; split inserts strip-rect after removing
2759 ;; top and bottom borders
2760 (let ((o-coord (table--get-coordinate))
2761 (l (setq strip-rect (cdr strip-rect))))
2762 (while (cddr l) (setq l (cdr l)))
2763 (setcdr l nil)
2764 ;; insert the strip only when it is not a completely blank one
2765 (unless (let ((cl (mapcar (lambda (s) (string= s " ")) strip-rect)))
2766 (and (car cl)
2767 (table--uniform-list-p cl)))
2768 (goto-char (point-min))
2769 (table--insert-rectangle strip-rect)
2770 (table--goto-coordinate o-coord)))
2771 ;; left or right inserts original contents
2772 (erase-buffer)
2773 (insert cell-contents)
2774 (table--goto-coordinate cell-coordinate)
2775 (table--fill-region (point-min) (point-max))
2776 ;; avoid unnecessary vertical cell expansion
2777 (and (looking-at "\\s *\\'")
2778 (re-search-backward "\\S \\(\\s *\\)\\=" nil t)
2779 (goto-char (match-beginning 1))))
2780 ;; in either case do not fill paragraph
2781 (setq table-inhibit-auto-fill-paragraph t))
2782 (table--update-cell 'now)) ;; can't defer this operation
2783 (table-recognize-cell 'force)))
2785 ;;;###autoload
2786 (defun table-split-cell (orientation)
2787 "Split current cell in ORIENTATION.
2788 ORIENTATION is a symbol either horizontally or vertically."
2789 (interactive
2790 (list
2791 (let* ((_ (barf-if-buffer-read-only))
2792 (completion-ignore-case t)
2793 (default (car table-cell-split-orientation-history)))
2794 (intern (downcase (completing-read
2795 (format "Split orientation (default %s): " default)
2796 '(("horizontally") ("vertically"))
2797 nil t nil 'table-cell-split-orientation-history default))))))
2798 (unless (memq orientation '(horizontally vertically))
2799 (error "Invalid orientation %s, must be horizontally or vertically"
2800 (symbol-name orientation)))
2801 (if (eq orientation 'horizontally)
2802 (table-split-cell-horizontally)
2803 (table-split-cell-vertically)))
2805 ;;;###autoload
2806 (defun table-justify (what justify)
2807 "Justify contents of a cell, a row of cells or a column of cells.
2808 WHAT is a symbol 'cell, 'row or 'column. JUSTIFY is a symbol 'left,
2809 'center, 'right, 'top, 'middle, 'bottom or 'none."
2810 (interactive
2811 (list (let* ((_ (barf-if-buffer-read-only))
2812 (completion-ignore-case t)
2813 (default (car table-target-history)))
2814 (intern (downcase (completing-read
2815 (format "Justify what (default %s): " default)
2816 '(("cell") ("row") ("column"))
2817 nil t nil 'table-target-history default))))
2818 (table--query-justification)))
2819 (funcall (intern (concat "table-justify-" (symbol-name what))) justify))
2821 ;;;###autoload
2822 (defun table-justify-cell (justify &optional paragraph)
2823 "Justify cell contents.
2824 JUSTIFY is a symbol 'left, 'center or 'right for horizontal, or 'top,
2825 'middle, 'bottom or 'none for vertical. When optional PARAGRAPH is
2826 non-nil the justify operation is limited to the current paragraph,
2827 otherwise the entire cell contents is justified."
2828 (interactive
2829 (list (table--query-justification)))
2830 (table--finish-delayed-tasks)
2831 (table-recognize-cell 'force)
2832 (table--justify-cell-contents justify paragraph))
2834 ;;;###autoload
2835 (defun table-justify-row (justify)
2836 "Justify cells of a row.
2837 JUSTIFY is a symbol 'left, 'center or 'right for horizontal, or top,
2838 'middle, 'bottom or 'none for vertical."
2839 (interactive
2840 (list (table--query-justification)))
2841 (let((cell-list (table--horizontal-cell-list nil nil 'top)))
2842 (table--finish-delayed-tasks)
2843 (save-excursion
2844 (while cell-list
2845 (let ((cell (car cell-list)))
2846 (setq cell-list (cdr cell-list))
2847 (goto-char (car cell))
2848 (table-recognize-cell 'force)
2849 (table--justify-cell-contents justify))))))
2851 ;;;###autoload
2852 (defun table-justify-column (justify)
2853 "Justify cells of a column.
2854 JUSTIFY is a symbol 'left, 'center or 'right for horizontal, or top,
2855 'middle, 'bottom or 'none for vertical."
2856 (interactive
2857 (list (table--query-justification)))
2858 (let((cell-list (table--vertical-cell-list nil nil 'left)))
2859 (table--finish-delayed-tasks)
2860 (save-excursion
2861 (while cell-list
2862 (let ((cell (car cell-list)))
2863 (setq cell-list (cdr cell-list))
2864 (goto-char (car cell))
2865 (table-recognize-cell 'force)
2866 (table--justify-cell-contents justify))))))
2868 ;;;###autoload
2869 (define-minor-mode table-fixed-width-mode
2870 "Cell width is fixed when this is non-nil.
2871 Normally it should be nil for allowing automatic cell width expansion
2872 that widens a cell when it is necessary. When non-nil, typing in a
2873 cell does not automatically expand the cell width. A word that is too
2874 long to fit in a cell is chopped into multiple lines. The chopped
2875 location is indicated by `table-word-continuation-char'. This
2876 variable's value can be toggled by \\[table-fixed-width-mode] at
2877 run-time."
2878 :tag "Fix Cell Width"
2879 :group 'table
2880 (table--finish-delayed-tasks)
2881 (table--update-cell-face))
2883 ;;;###autoload
2884 (defun table-query-dimension (&optional where)
2885 "Return the dimension of the current cell and the current table.
2886 The result is a list (cw ch tw th c r cells) where cw is the cell
2887 width, ch is the cell height, tw is the table width, th is the table
2888 height, c is the number of columns, r is the number of rows and cells
2889 is the total number of cells. The cell dimension excludes the cell
2890 frame while the table dimension includes the table frame. The columns
2891 and the rows are counted by the number of cell boundaries. Therefore
2892 the number tends to be larger than it appears for the tables with
2893 non-uniform cell structure (heavily spanned and split). When optional
2894 WHERE is provided the cell and table at that location is reported."
2895 (interactive)
2896 (save-excursion
2897 (if where (goto-char where))
2898 (let ((starting-cell (table--probe-cell))
2899 cell table-lu table-rb col-list row-list (cells 0))
2900 (if (null starting-cell) nil
2901 (setq table-lu (car starting-cell))
2902 (setq table-rb (cdr starting-cell))
2903 (setq col-list (cons (car (table--get-coordinate (car starting-cell))) nil))
2904 (setq row-list (cons (cdr (table--get-coordinate (car starting-cell))) nil))
2905 (and (called-interactively-p 'interactive)
2906 (message "Computing cell dimension..."))
2907 (while
2908 (progn
2909 (table-forward-cell 1 t)
2910 (setq cells (1+ cells))
2911 (and (setq cell (table--probe-cell))
2912 (not (equal cell starting-cell))))
2913 (if (< (car cell) table-lu)
2914 (setq table-lu (car cell)))
2915 (if (> (cdr cell) table-rb)
2916 (setq table-rb (cdr cell)))
2917 (let ((lu-coordinate (table--get-coordinate (car cell))))
2918 (if (memq (car lu-coordinate) col-list) nil
2919 (setq col-list (cons (car lu-coordinate) col-list)))
2920 (if (memq (cdr lu-coordinate) row-list) nil
2921 (setq row-list (cons (cdr lu-coordinate) row-list)))))
2922 (let* ((cell-lu-coordinate (table--get-coordinate (car starting-cell)))
2923 (cell-rb-coordinate (table--get-coordinate (cdr starting-cell)))
2924 (table-lu-coordinate (table--get-coordinate table-lu))
2925 (table-rb-coordinate (table--get-coordinate table-rb))
2926 (cw (- (car cell-rb-coordinate) (car cell-lu-coordinate)))
2927 (ch (1+ (- (cdr cell-rb-coordinate) (cdr cell-lu-coordinate))))
2928 (tw (+ 2 (- (car table-rb-coordinate) (car table-lu-coordinate))))
2929 (th (+ 3 (- (cdr table-rb-coordinate) (cdr table-lu-coordinate))))
2930 (c (length col-list))
2931 (r (length row-list)))
2932 (and (called-interactively-p 'interactive)
2933 (message "Cell: (%dw, %dh), Table: (%dw, %dh), Dim: (%dc, %dr), Total Cells: %d" cw ch tw th c r cells))
2934 (list cw ch tw th c r cells))))))
2936 ;;;###autoload
2937 (defun table-generate-source (language &optional dest-buffer caption)
2938 "Generate source of the current table in the specified language.
2939 LANGUAGE is a symbol that specifies the language to describe the
2940 structure of the table. It must be either 'html, 'latex or 'cals.
2941 The resulted source text is inserted into DEST-BUFFER and the buffer
2942 object is returned. When DEST-BUFFER is omitted or nil the default
2943 buffer specified in `table-dest-buffer-name' is used. In this case
2944 the content of the default buffer is erased prior to the generation.
2945 When DEST-BUFFER is non-nil it is expected to be either a destination
2946 buffer or a name of the destination buffer. In this case the
2947 generated result is inserted at the current point in the destination
2948 buffer and the previously existing contents in the buffer are
2949 untouched.
2951 References used for this implementation:
2953 HTML:
2954 URL `http://www.w3.org'
2956 LaTeX:
2957 URL `http://www.maths.tcd.ie/~dwilkins/LaTeXPrimer/Tables.html'
2959 CALS (DocBook DTD):
2960 URL `http://www.oasis-open.org/html/a502.htm'
2961 URL `http://www.oreilly.com/catalog/docbook/chapter/book/table.html#AEN114751'
2963 (interactive
2964 (let* ((_ (unless (table--probe-cell) (error "Table not found here")))
2965 (completion-ignore-case t)
2966 (default (car table-source-language-history))
2967 (language (downcase (completing-read
2968 (format "Language (default %s): " default)
2969 (mapcar (lambda (s) (list (symbol-name s)))
2970 table-source-languages)
2971 nil t nil 'table-source-language-history default))))
2972 (list
2973 (intern language)
2974 (read-buffer "Destination buffer: " (concat table-dest-buffer-name "." language))
2975 (table--read-from-minibuffer '("Table Caption" . table-source-caption-history)))))
2976 (let ((default-buffer-name (concat table-dest-buffer-name "." (symbol-name language))))
2977 (unless (or (called-interactively-p 'interactive) (table--probe-cell))
2978 (error "Table not found here"))
2979 (unless (bufferp dest-buffer)
2980 (setq dest-buffer (get-buffer-create (or dest-buffer default-buffer-name))))
2981 (if (string= (buffer-name dest-buffer) default-buffer-name)
2982 (with-current-buffer dest-buffer
2983 (erase-buffer)))
2984 (save-excursion
2985 (let ((starting-cell (table--probe-cell))
2986 cell origin-cell tail-cell col-list row-list (n 0) i)
2987 ;; first analyze the table structure and prepare:
2988 ;; 1. origin cell (left up corner cell)
2989 ;; 2. tail cell (right bottom corner cell)
2990 ;; 3. column boundary list
2991 ;; 4. row boundary list
2992 (setq origin-cell starting-cell)
2993 (setq tail-cell starting-cell)
2994 (setq col-list (cons (car (table--get-coordinate (car starting-cell))) nil))
2995 (setq row-list (cons (cdr (table--get-coordinate (car starting-cell))) nil))
2996 (setq i 0)
2997 (let ((wheel [?- ?\\ ?| ?/]))
2998 (while
2999 (progn
3000 (if (called-interactively-p 'interactive)
3001 (progn
3002 (message "Analyzing table...%c" (aref wheel i))
3003 (if (eq (setq i (1+ i)) (length wheel))
3004 (setq i 0))
3005 (setq n (1+ n))))
3006 (table-forward-cell 1 t)
3007 (and (setq cell (table--probe-cell))
3008 (not (equal cell starting-cell))))
3009 (if (< (car cell) (car origin-cell))
3010 (setq origin-cell cell))
3011 (if (> (cdr cell) (cdr tail-cell))
3012 (setq tail-cell cell))
3013 (let ((lu-coordinate (table--get-coordinate (car cell))))
3014 (unless (memq (car lu-coordinate) col-list)
3015 (setq col-list (cons (car lu-coordinate) col-list)))
3016 (unless (memq (cdr lu-coordinate) row-list)
3017 (setq row-list (cons (cdr lu-coordinate) row-list))))))
3018 (setq col-list (sort col-list '<))
3019 (setq row-list (sort row-list '<))
3020 (message "Generating source...")
3021 ;; clear the source generation property list
3022 (setplist 'table-source-info-plist nil)
3023 ;; prepare to start from the origin cell
3024 (goto-char (car origin-cell))
3025 ;; first put some header information
3026 (table--generate-source-prologue dest-buffer language caption col-list row-list)
3027 (cond
3028 ((eq language 'latex)
3029 ;; scan by character lines
3030 (table--generate-source-scan-lines dest-buffer language origin-cell tail-cell col-list row-list))
3032 ;; scan by table cells
3033 (table--generate-source-scan-rows dest-buffer language origin-cell col-list row-list)))
3034 ;; insert closing
3035 (table--generate-source-epilogue dest-buffer language col-list row-list))
3036 ;; lastly do some convenience work
3037 (if (called-interactively-p 'interactive)
3038 (save-selected-window
3039 (pop-to-buffer dest-buffer t)
3040 (goto-char (point-min))
3041 (and (string= (buffer-name dest-buffer) default-buffer-name)
3042 (buffer-file-name dest-buffer)
3043 (save-buffer))
3044 (message "Generating source...done")
3045 (let ((mode
3046 (if (memq language '(cals)) 'sgml-mode
3047 (intern (concat (symbol-name language) "-mode")))))
3048 (if (fboundp mode)
3049 (call-interactively mode)))
3051 dest-buffer))
3053 (defun table--generate-source-prologue (dest-buffer language caption col-list _row-list)
3054 "Generate and insert source prologue into DEST-BUFFER."
3055 (with-current-buffer dest-buffer
3056 (cond
3057 ((eq language 'html)
3058 (insert (format "<!-- This HTML table template is generated by emacs %s -->\n" emacs-version)
3059 (format "<table %s>\n" table-html-table-attribute)
3060 (if (and (stringp caption)
3061 (not (string= caption "")))
3062 (format " <caption>%s</caption>\n" caption)
3063 "")))
3064 ((eq language 'latex)
3065 (insert (format "%% This LaTeX table template is generated by emacs %s\n" emacs-version)
3066 "\\begin{tabular}{|" (apply 'concat (make-list (length col-list) "l|")) "}\n"
3067 "\\hline\n"))
3068 ((eq language 'cals)
3069 (insert (format "<!-- This CALS table template is generated by emacs %s -->\n" emacs-version)
3070 "<table frame=\"all\">\n")
3071 (if (and (stringp caption)
3072 (not (string= caption "")))
3073 (insert " <title>" caption "</title>\n"))
3074 (insert (format " <tgroup cols=\"%d\" align=\"left\" colsep=\"1\" rowsep=\"1\">\n" (length col-list)))
3075 (table-put-source-info 'colspec-marker (point-marker))
3076 (table-put-source-info 'row-type (if (zerop table-cals-thead-rows) "tbody" "thead"))
3077 (set-marker-insertion-type (table-get-source-info 'colspec-marker) nil) ;; insert after
3078 (insert (format " <%s valign=\"top\">\n" (table-get-source-info 'row-type))))
3081 (defun table--generate-source-epilogue (dest-buffer language _col-list _row-list)
3082 "Generate and insert source epilogue into DEST-BUFFER."
3083 (with-current-buffer dest-buffer
3084 (cond
3085 ((eq language 'html)
3086 (insert "</table>\n"))
3087 ((eq language 'latex)
3088 (insert "\\end{tabular}\n"))
3089 ((eq language 'cals)
3090 (set-marker-insertion-type (table-get-source-info 'colspec-marker) t) ;; insert before
3091 (save-excursion
3092 (goto-char (table-get-source-info 'colspec-marker))
3093 (dolist (col (sort (table-get-source-info 'colnum-list) '<))
3094 (insert (format " <colspec colnum=\"%d\" colname=\"c%d\"/>\n" col col))))
3095 (insert (format " </%s>\n </tgroup>\n</table>\n" (table-get-source-info 'row-type))))
3098 (defun table--generate-source-scan-rows (dest-buffer language _origin-cell col-list row-list)
3099 "Generate and insert source rows into DEST-BUFFER."
3100 (table-put-source-info 'current-row 1)
3101 (while row-list
3102 (with-current-buffer dest-buffer
3103 (cond
3104 ((eq language 'html)
3105 (insert " <tr>\n"))
3106 ((eq language 'cals)
3107 (insert " <row>\n"))
3109 (table--generate-source-cells-in-a-row dest-buffer language col-list row-list)
3110 (with-current-buffer dest-buffer
3111 (cond
3112 ((eq language 'html)
3113 (insert " </tr>\n"))
3114 ((eq language 'cals)
3115 (insert " </row>\n")
3116 (unless (/= (table-get-source-info 'current-row) table-cals-thead-rows)
3117 (insert (format " </%s>\n" (table-get-source-info 'row-type)))
3118 (insert (format " <%s valign=\"top\">\n" (table-put-source-info 'row-type "tbody")))))))
3119 (table-put-source-info 'current-row (1+ (table-get-source-info 'current-row)))
3120 (setq row-list (cdr row-list))))
3122 (defun table--generate-source-cells-in-a-row (dest-buffer language col-list row-list)
3123 "Generate and insert source cells into DEST-BUFFER."
3124 (table-put-source-info 'current-column 1)
3125 (while col-list
3126 (let* ((cell (table--probe-cell))
3127 (lu (table--get-coordinate (car cell)))
3128 (rb (table--get-coordinate (cdr cell)))
3129 (alignment (table--get-cell-justify-property cell))
3130 (valign (table--get-cell-valign-property cell))
3131 (row-list row-list)
3132 (colspan 1)
3133 (rowspan 1))
3134 (if (< (car lu) (car col-list))
3135 (setq col-list nil)
3136 (while (and col-list
3137 (> (car lu) (car col-list)))
3138 (setq col-list (cdr col-list))
3139 (table-put-source-info 'current-column (1+ (table-get-source-info 'current-column))))
3140 (setq col-list (cdr col-list))
3141 (table-put-source-info 'next-column (1+ (table-get-source-info 'current-column)))
3142 (while (and col-list
3143 (> (1+ (car rb)) (car col-list)))
3144 (setq colspan (1+ colspan))
3145 (setq col-list (cdr col-list))
3146 (table-put-source-info 'next-column (1+ (table-get-source-info 'next-column))))
3147 (setq row-list (cdr row-list))
3148 (while (and row-list
3149 (> (+ (cdr rb) 2) (car row-list)))
3150 (setq rowspan (1+ rowspan))
3151 (setq row-list (cdr row-list)))
3152 (with-current-buffer dest-buffer
3153 (cond
3154 ((eq language 'html)
3155 (insert (format " <%s"
3156 (table-put-source-info
3157 'cell-type
3158 (if (or (<= (table-get-source-info 'current-row) table-html-th-rows)
3159 (<= (table-get-source-info 'current-column) table-html-th-columns))
3160 "th" "td"))))
3161 (if (and table-html-cell-attribute (not (string= table-html-cell-attribute "")))
3162 (insert " " table-html-cell-attribute))
3163 (if (> colspan 1) (insert (format " colspan=\"%d\"" colspan)))
3164 (if (> rowspan 1) (insert (format " rowspan=\"%d\"" rowspan)))
3165 (insert (format " align=\"%s\"" (if alignment (symbol-name alignment) "left")))
3166 (insert (format " valign=\"%s\"" (if valign (symbol-name valign) "top")))
3167 (insert ">\n"))
3168 ((eq language 'cals)
3169 (insert " <entry")
3170 (if (> colspan 1)
3171 (let ((scol (table-get-source-info 'current-column))
3172 (ecol (+ (table-get-source-info 'current-column) colspan -1)))
3173 (mapc (lambda (col)
3174 (unless (memq col (table-get-source-info 'colnum-list))
3175 (table-put-source-info 'colnum-list
3176 (cons col (table-get-source-info 'colnum-list)))))
3177 (list scol ecol))
3178 (insert (format " namest=\"c%d\" nameend=\"c%d\"" scol ecol))))
3179 (if (> rowspan 1) (insert (format " morerows=\"%d\"" (1- rowspan))))
3180 (if (and alignment
3181 (not (memq alignment '(left none))))
3182 (insert " align=\"" (symbol-name alignment) "\""))
3183 (if (and valign
3184 (not (memq valign '(top none))))
3185 (insert " valign=\"" (symbol-name valign) "\""))
3186 (insert ">\n"))
3188 (table--generate-source-cell-contents dest-buffer language cell)
3189 (with-current-buffer dest-buffer
3190 (cond
3191 ((eq language 'html)
3192 (insert (format" </%s>\n" (table-get-source-info 'cell-type))))
3193 ((eq language 'cals)
3194 (insert " </entry>\n"))
3196 (table-forward-cell 1 t)
3197 (table-put-source-info 'current-column (table-get-source-info 'next-column))
3198 ))))
3200 (defun table--generate-source-cell-contents (dest-buffer language cell)
3201 "Generate and insert source cell contents of a CELL into DEST-BUFFER."
3202 (let ((cell-contents (extract-rectangle (car cell) (cdr cell))))
3203 (with-temp-buffer
3204 (table--insert-rectangle cell-contents)
3205 (table--remove-cell-properties (point-min) (point-max))
3206 (goto-char (point-min))
3207 (cond
3208 ((eq language 'html)
3209 (if table-html-delegate-spacing-to-user-agent
3210 (progn
3211 (table--remove-eol-spaces (point-min) (point-max))
3212 (if (re-search-forward "\\s +\\'" nil t)
3213 (replace-match "")))
3214 (while (search-forward " " nil t)
3215 (replace-match "&nbsp;"))
3216 (goto-char (point-min))
3217 (while (and (re-search-forward "$" nil t)
3218 (not (eobp)))
3219 (insert "<br />")
3220 (forward-char 1)))
3221 (unless (and table-html-delegate-spacing-to-user-agent
3222 (progn
3223 (goto-char (point-min))
3224 (looking-at "\\s *\\'")))))
3225 ((eq language 'cals)
3226 (table--remove-eol-spaces (point-min) (point-max))
3227 (if (re-search-forward "\\s +\\'" nil t)
3228 (replace-match "")))
3230 (setq cell-contents (buffer-substring (point-min) (point-max))))
3231 (with-current-buffer dest-buffer
3232 (let ((beg (point)))
3233 (insert cell-contents)
3234 (indent-rigidly beg (point)
3235 (cond
3236 ((eq language 'html) 6)
3237 ((eq language 'cals) 10)))
3238 (insert ?\n)))))
3240 (defun table--cell-horizontal-char-p (c)
3241 "Test if character C is one of the horizontal characters"
3242 (memq c (string-to-list table-cell-horizontal-chars)))
3244 (defun table--generate-source-scan-lines (dest-buffer _language origin-cell tail-cell col-list row-list)
3245 "Scan the table line by line.
3246 Currently this method is for LaTeX only."
3247 (let* ((lu-coord (table--get-coordinate (car origin-cell)))
3248 (rb-coord (table--get-coordinate (cdr tail-cell)))
3249 (x0 (car lu-coord))
3250 (x1 (car rb-coord))
3251 (y (cdr lu-coord))
3252 (y1 (cdr rb-coord)))
3253 (while (<= y y1)
3254 (let* ((border-p (memq (1+ y) row-list))
3255 (border-char-list
3256 (mapcar (lambda (x)
3257 (if border-p (char-after (table--goto-coordinate (cons x y)))
3258 (char-before (table--goto-coordinate (cons x y)))))
3259 col-list))
3260 start i c)
3261 (if border-p
3262 ;; horizontal cell border processing
3263 (if (and (table--cell-horizontal-char-p (car border-char-list))
3264 (table--uniform-list-p border-char-list))
3265 (with-current-buffer dest-buffer
3266 (insert "\\hline\n"))
3267 (setq i 0)
3268 (while (setq c (nth i border-char-list))
3269 (if (and start (not (table--cell-horizontal-char-p c)))
3270 (progn
3271 (with-current-buffer dest-buffer
3272 (insert (format "\\cline{%d-%d}\n" (1+ start) i)))
3273 (setq start nil)))
3274 (if (and (not start) (table--cell-horizontal-char-p c))
3275 (setq start i))
3276 (setq i (1+ i)))
3277 (if start
3278 (with-current-buffer dest-buffer
3279 (insert (format "\\cline{%d-%d}\n" (1+ start) i)))))
3280 ;; horizontal cell contents processing
3281 (let* ((span 1) ;; spanning length
3282 (first-p t) ;; first in a row
3283 (insert-column ;; a function that processes one column/multicolumn
3284 (function
3285 (lambda (from to)
3286 (let ((line (table--buffer-substring-and-trim
3287 (table--goto-coordinate (cons from y))
3288 (table--goto-coordinate (cons to y)))))
3289 ;; escape special characters
3290 (with-temp-buffer
3291 (insert line)
3292 (goto-char (point-min))
3293 (while (re-search-forward "\\([#$~_^%{}]\\)\\|\\(\\\\\\)\\|\\([<>|]\\)" nil t)
3294 (if (match-beginning 1)
3295 (save-excursion
3296 (goto-char (match-beginning 1))
3297 (insert "\\"))
3298 (if (match-beginning 2)
3299 (replace-match "$\\backslash$" t t)
3300 (replace-match (concat "$" (match-string 3) "$")) t t)))
3301 (setq line (buffer-substring (point-min) (point-max))))
3302 ;; insert a column separator and column/multicolumn contents
3303 (with-current-buffer dest-buffer
3304 (unless first-p
3305 (insert (if (eq (char-before) ?\s) "" " ") "& "))
3306 (if (> span 1)
3307 (insert (format "\\multicolumn{%d}{%sl|}{%s}" span (if first-p "|" "") line))
3308 (insert line)))
3309 (setq first-p nil)
3310 (setq span 1)
3311 (setq start (nth i col-list)))))))
3312 (setq start x0)
3313 (setq i 1)
3314 (while (setq c (nth i border-char-list))
3315 (if (eq c table-cell-vertical-char)
3316 (funcall insert-column start (1- (nth i col-list)))
3317 (setq span (1+ span)))
3318 (setq i (1+ i)))
3319 (funcall insert-column start x1))
3320 (with-current-buffer dest-buffer
3321 (insert (if (eq (char-before) ?\s) "" " ") "\\\\\n"))))
3322 (setq y (1+ y)))
3323 (with-current-buffer dest-buffer
3324 (insert "\\hline\n"))
3327 ;;;###autoload
3328 (defun table-insert-sequence (str n increment interval justify)
3329 "Travel cells forward while inserting a specified sequence string in each cell.
3330 STR is the base string from which the sequence starts. When STR is an
3331 empty string then each cell content is erased. When STR ends with
3332 numerical characters (they may optionally be surrounded by a pair of
3333 parentheses) they are incremented as a decimal number. Otherwise the
3334 last character in STR is incremented in ASCII code order. N is the
3335 number of sequence elements to insert. When N is negative the cell
3336 traveling direction is backward. When N is zero it travels forward
3337 entire table. INCREMENT is the increment between adjacent sequence
3338 elements and can be a negative number for effectively decrementing.
3339 INTERVAL is the number of cells to travel between sequence element
3340 insertion which is normally 1. When zero or less is given for
3341 INTERVAL it is interpreted as number of cells per row so that sequence
3342 is placed straight down vertically as long as the table's cell
3343 structure is uniform. JUSTIFY is one of the symbol 'left, 'center or
3344 'right, that specifies justification of the inserted string.
3346 Example:
3348 (progn
3349 (table-insert 16 3 5 1)
3350 (table-forward-cell 15)
3351 (table-insert-sequence \"D0\" -16 1 1 'center)
3352 (table-forward-cell 16)
3353 (table-insert-sequence \"A[0]\" -16 1 1 'center)
3354 (table-forward-cell 1)
3355 (table-insert-sequence \"-\" 16 0 1 'center))
3357 (progn
3358 (table-insert 16 8 5 1)
3359 (table-insert-sequence \"@\" 0 1 2 'right)
3360 (table-forward-cell 1)
3361 (table-insert-sequence \"64\" 0 1 2 'left))"
3362 (interactive
3363 (progn
3364 (barf-if-buffer-read-only)
3365 (unless (table--probe-cell) (error "Table not found here"))
3366 (list (read-from-minibuffer
3367 "Sequence base string: " (car table-sequence-string-history) nil nil 'table-sequence-string-history)
3368 (string-to-number
3369 (table--read-from-minibuffer
3370 '("How many elements (0: maximum, negative: backward traveling)" . table-sequence-count-history)))
3371 (string-to-number
3372 (table--read-from-minibuffer
3373 '("Increment element by" . table-sequence-increment-history)))
3374 (string-to-number
3375 (table--read-from-minibuffer
3376 '("Cell interval (0: vertical, 1:horizontal)" . table-sequence-interval-history)))
3377 (let* ((completion-ignore-case t)
3378 (default (car table-sequence-justify-history)))
3379 (intern (downcase (completing-read
3380 (format "Justify (default %s): " default)
3381 '(("left") ("center") ("right"))
3382 nil t nil 'table-sequence-justify-history default)))))))
3383 (unless (or (called-interactively-p 'interactive) (table--probe-cell))
3384 (error "Table not found here"))
3385 (string-match "\\([0-9]*\\)\\([]})>]*\\)\\'" str)
3386 (if (called-interactively-p 'interactive)
3387 (message "Sequencing..."))
3388 (let* ((prefix (substring str 0 (match-beginning 1)))
3389 (index (match-string 1 str))
3390 (fmt (format "%%%s%dd" (if (eq (string-to-char index) ?0) "0" "") (length index)))
3391 (postfix (match-string 2 str))
3392 (dim (table-query-dimension))
3393 (cells (nth 6 dim))
3394 (direction (if (< n 0) -1 1))
3395 (interval-count 0))
3396 (if (string= index "")
3397 (progn
3398 (setq index nil)
3399 (if (string= prefix "")
3400 (setq prefix nil)))
3401 (setq index (string-to-number index)))
3402 (if (< n 0) (setq n (- n)))
3403 (if (or (zerop n) (> n cells)) (setq n cells))
3404 (if (< interval 0) (setq interval (- interval)))
3405 (if (zerop interval) (setq interval (nth 4 dim)))
3406 (save-excursion
3407 (while (progn
3408 (if (> interval-count 0) nil
3409 (setq interval-count interval)
3410 (table-with-cache-buffer
3411 (goto-char (point-min))
3412 (if (not (or prefix index))
3413 (erase-buffer)
3414 (insert prefix)
3415 (if index (insert (format fmt index)))
3416 (insert postfix)
3417 (table--fill-region (point-min) (point) table-cell-info-width justify)
3418 (setq table-cell-info-justify justify))
3419 (setq table-inhibit-auto-fill-paragraph t))
3420 (table--update-cell 'now)
3421 (if index
3422 (setq index (+ index increment))
3423 (if (and prefix (string= postfix ""))
3424 (let ((len-1 (1- (length prefix))))
3425 (setq prefix (concat (substring prefix 0 len-1)
3426 (char-to-string
3427 (+ (string-to-char (substring prefix len-1)) increment)))))))
3428 (setq n (1- n)))
3429 (table-forward-cell direction t)
3430 (setq interval-count (1- interval-count))
3431 (setq cells (1- cells))
3432 (and (> n 0) (> cells 0)))))
3433 (table-recognize-cell 'force)
3434 (if (called-interactively-p 'interactive)
3435 (message "Sequencing...done"))
3438 ;;;###autoload
3439 (defun table-delete-row (n)
3440 "Delete N row(s) of cells.
3441 Delete N rows of cells from current row. The current row is the row
3442 contains the current cell where point is located. Each row must
3443 consists from cells of same height."
3444 (interactive "*p")
3445 (let ((orig-coord (table--get-coordinate))
3446 (bt-coord (table--get-coordinate (cdr (table--vertical-cell-list nil 'first-only))))
3447 lu-coord rb-coord rect)
3448 ;; determine the area to delete while testing row height uniformity
3449 (while (> n 0)
3450 (setq n (1- n))
3451 (unless (table--probe-cell)
3452 (error "Table not found"))
3453 (let ((cell-list (table--horizontal-cell-list 'left-to-right)))
3454 (unless
3455 (and (table--uniform-list-p
3456 (mapcar (lambda (cell) (cdr (table--get-coordinate (car cell)))) cell-list))
3457 (table--uniform-list-p
3458 (mapcar (lambda (cell) (cdr (table--get-coordinate (cdr cell)))) cell-list)))
3459 (error "Cells in this row are not in uniform height"))
3460 (unless lu-coord
3461 (setq lu-coord (table--get-coordinate (caar cell-list))))
3462 (setq rb-coord (table--get-coordinate (cdar (last cell-list))))
3463 (table--goto-coordinate (cons (car orig-coord) (+ 2 (cdr rb-coord))))))
3464 ;; copy the remaining area (below the deleting area)
3465 (setq rect (extract-rectangle
3466 (table--goto-coordinate (cons (1- (car lu-coord)) (1+ (cdr rb-coord))))
3467 (table--goto-coordinate (cons (1+ (car rb-coord)) (1+ (cdr bt-coord))))))
3468 ;; delete the deleting area and below together
3469 (delete-rectangle
3470 (table--goto-coordinate (cons (1- (car lu-coord)) (1- (cdr lu-coord))))
3471 (table--goto-coordinate (cons (1+ (car rb-coord)) (1+ (cdr bt-coord)))))
3472 (table--goto-coordinate (cons (1- (car lu-coord)) (1- (cdr lu-coord))))
3473 ;; insert the remaining area while appending blank lines below it
3474 (table--insert-rectangle
3475 (append rect (make-list (+ 2 (- (cdr rb-coord) (cdr lu-coord)))
3476 (make-string (+ 2 (- (car rb-coord) (car lu-coord))) ?\s))))
3477 ;; remove the appended blank lines below the table if they are unnecessary
3478 (table--goto-coordinate (cons 0 (- (cdr bt-coord) (- (cdr rb-coord) (cdr lu-coord)))))
3479 (table--remove-blank-lines (+ 2 (- (cdr rb-coord) (cdr lu-coord))))
3480 ;; fix up intersections
3481 (let ((coord (cons (car lu-coord) (1- (cdr lu-coord))))
3482 (n (1+ (- (car rb-coord) (car lu-coord)))))
3483 (while (> n 0)
3484 (table--goto-coordinate coord)
3485 (if (save-excursion
3486 (or (and (table--goto-coordinate (cons (car coord) (1- (cdr coord))) 'no-extension)
3487 (looking-at (regexp-quote (char-to-string table-cell-vertical-char))))
3488 (and (table--goto-coordinate (cons (car coord) (1+ (cdr coord))) 'no-extension)
3489 (looking-at (regexp-quote (char-to-string table-cell-vertical-char))))))
3490 (progn
3491 (delete-char 1)
3492 (insert table-cell-intersection-char))
3493 (delete-char 1)
3494 (insert (string-to-char table-cell-horizontal-chars)))
3495 (setq n (1- n))
3496 (setcar coord (1+ (car coord)))))
3497 ;; goto appropriate end point
3498 (table--goto-coordinate (cons (car orig-coord) (cdr lu-coord)))))
3500 ;;;###autoload
3501 (defun table-delete-column (n)
3502 "Delete N column(s) of cells.
3503 Delete N columns of cells from current column. The current column is
3504 the column contains the current cell where point is located. Each
3505 column must consists from cells of same width."
3506 (interactive "*p")
3507 (let ((orig-coord (table--get-coordinate))
3508 lu-coord rb-coord)
3509 ;; determine the area to delete while testing column width uniformity
3510 (while (> n 0)
3511 (setq n (1- n))
3512 (unless (table--probe-cell)
3513 (error "Table not found"))
3514 (let ((cell-list (table--vertical-cell-list 'top-to-bottom)))
3515 (unless
3516 (and (table--uniform-list-p
3517 (mapcar (function (lambda (cell) (car (table--get-coordinate (car cell))))) cell-list))
3518 (table--uniform-list-p
3519 (mapcar (function (lambda (cell) (car (table--get-coordinate (cdr cell))))) cell-list)))
3520 (error "Cells in this column are not in uniform width"))
3521 (unless lu-coord
3522 (setq lu-coord (table--get-coordinate (caar cell-list))))
3523 (setq rb-coord (table--get-coordinate (cdar (last cell-list))))
3524 (table--goto-coordinate (cons (1+ (car rb-coord)) (cdr orig-coord)))))
3525 ;; delete the area
3526 (delete-rectangle
3527 (table--goto-coordinate (cons (car lu-coord) (1- (cdr lu-coord))))
3528 (table--goto-coordinate (cons (1+ (car rb-coord)) (1+ (cdr rb-coord)))))
3529 ;; fix up the intersections
3530 (let ((coord (cons (1- (car lu-coord)) (cdr lu-coord)))
3531 (n (1+ (- (cdr rb-coord) (cdr lu-coord)))))
3532 (while (> n 0)
3533 (table--goto-coordinate coord)
3534 (if (save-excursion
3535 (or (and (table--goto-coordinate (cons (1- (car coord)) (cdr coord)) 'no-extension)
3536 (looking-at (regexp-opt-charset
3537 (string-to-list table-cell-horizontal-chars))))
3538 (and (table--goto-coordinate (cons (1+ (car coord)) (cdr coord)) 'no-extension)
3539 (looking-at (regexp-opt-charset
3540 (string-to-list table-cell-horizontal-chars))))))
3541 (progn
3542 (delete-char 1)
3543 (insert table-cell-intersection-char))
3544 (delete-char 1)
3545 (insert table-cell-vertical-char))
3546 (setq n (1- n))
3547 (setcdr coord (1+ (cdr coord)))))
3548 ;; goto appropriate end point
3549 (table--goto-coordinate (cons (car lu-coord) (cdr orig-coord)))))
3551 ;;;###autoload
3552 (defun table-capture (beg end &optional col-delim-regexp row-delim-regexp justify min-cell-width columns)
3553 "Convert plain text into a table by capturing the text in the region.
3554 Create a table with the text in region as cell contents. BEG and END
3555 specify the region. The text in the region is replaced with a table.
3556 The removed text is inserted in the table. When optional
3557 COL-DELIM-REGEXP and ROW-DELIM-REGEXP are provided the region contents
3558 is parsed and separated into individual cell contents by using the
3559 delimiter regular expressions. This parsing determines the number of
3560 columns and rows of the table automatically. If COL-DELIM-REGEXP and
3561 ROW-DELIM-REGEXP are omitted the result table has only one cell and
3562 the entire region contents is placed in that cell. Optional JUSTIFY
3563 is one of 'left, 'center or 'right, which specifies the cell
3564 justification. Optional MIN-CELL-WIDTH specifies the minimum cell
3565 width. Optional COLUMNS specify the number of columns when
3566 ROW-DELIM-REGEXP is not specified.
3569 Example 1:
3571 1, 2, 3, 4
3572 5, 6, 7, 8
3573 , 9, 10
3575 Running `table-capture' on above 3 line region with COL-DELIM-REGEXP
3576 \",\" and ROW-DELIM-REGEXP \"\\n\" creates the following table. In
3577 this example the cells are centered and minimum cell width is
3578 specified as 5.
3580 +-----+-----+-----+-----+
3581 | 1 | 2 | 3 | 4 |
3582 +-----+-----+-----+-----+
3583 | 5 | 6 | 7 | 8 |
3584 +-----+-----+-----+-----+
3585 | | 9 | 10 | |
3586 +-----+-----+-----+-----+
3588 Note:
3590 In case the function is called interactively user must use \\[quoted-insert] `quoted-insert'
3591 in order to enter \"\\n\" successfully. COL-DELIM-REGEXP at the end
3592 of each row is optional.
3595 Example 2:
3597 This example shows how a table can be used for text layout editing.
3598 Let `table-capture' capture the following region starting from
3599 -!- and ending at -*-, that contains three paragraphs and two item
3600 name headers. This time specify empty string for both
3601 COL-DELIM-REGEXP and ROW-DELIM-REGEXP.
3603 -!-`table-capture' is a powerful command however mastering its power
3604 requires some practice. Here is a list of items what it can do.
3606 Parse Cell Items By using column delimiter regular
3607 expression and raw delimiter regular
3608 expression, it parses the specified text
3609 area and extracts cell items from
3610 non-table text and then forms a table out
3611 of them.
3613 Capture Text Area When no delimiters are specified it
3614 creates a single cell table. The text in
3615 the specified region is placed in that
3616 cell.-*-
3618 Now the entire content is captured in a cell which is itself a table
3619 like this.
3621 +-----------------------------------------------------------------+
3622 |`table-capture' is a powerful command however mastering its power|
3623 |requires some practice. Here is a list of items what it can do. |
3625 |Parse Cell Items By using column delimiter regular |
3626 | expression and raw delimiter regular |
3627 | expression, it parses the specified text |
3628 | area and extracts cell items from |
3629 | non-table text and then forms a table out |
3630 | of them. |
3632 |Capture Text Area When no delimiters are specified it |
3633 | creates a single cell table. The text in |
3634 | the specified region is placed in that |
3635 | cell. |
3636 +-----------------------------------------------------------------+
3638 By splitting the cell appropriately we now have a table consisting of
3639 paragraphs occupying its own cell. Each cell can now be edited
3640 independently.
3642 +-----------------------------------------------------------------+
3643 |`table-capture' is a powerful command however mastering its power|
3644 |requires some practice. Here is a list of items what it can do. |
3645 +---------------------+-------------------------------------------+
3646 |Parse Cell Items |By using column delimiter regular |
3647 | |expression and raw delimiter regular |
3648 | |expression, it parses the specified text |
3649 | |area and extracts cell items from |
3650 | |non-table text and then forms a table out |
3651 | |of them. |
3652 +---------------------+-------------------------------------------+
3653 |Capture Text Area |When no delimiters are specified it |
3654 | |creates a single cell table. The text in |
3655 | |the specified region is placed in that |
3656 | |cell. |
3657 +---------------------+-------------------------------------------+
3659 By applying `table-release', which does the opposite process, the
3660 contents become once again plain text. `table-release' works as
3661 companion command to `table-capture' this way.
3663 (interactive
3664 (let ((col-delim-regexp)
3665 (row-delim-regexp))
3666 (barf-if-buffer-read-only)
3667 (if (table--probe-cell)
3668 (error "Can't insert a table inside a table"))
3669 (list
3670 (mark) (point)
3671 (setq col-delim-regexp
3672 (read-from-minibuffer "Column delimiter regexp: "
3673 (car table-col-delim-regexp-history) nil nil 'table-col-delim-regexp-history))
3674 (setq row-delim-regexp
3675 (read-from-minibuffer "Row delimiter regexp: "
3676 (car table-row-delim-regexp-history) nil nil 'table-row-delim-regexp-history))
3677 (let* ((completion-ignore-case t)
3678 (default (car table-capture-justify-history)))
3679 (if (and (string= col-delim-regexp "") (string= row-delim-regexp "")) 'left
3680 (intern
3681 (downcase (completing-read
3682 (format "Justify (default %s): " default)
3683 '(("left") ("center") ("right"))
3684 nil t nil 'table-capture-justify-history default)))))
3685 (if (and (string= col-delim-regexp "") (string= row-delim-regexp "")) "1"
3686 (table--read-from-minibuffer '("Minimum cell width" . table-capture-min-cell-width-history)))
3687 (if (and (not (string= col-delim-regexp "")) (string= row-delim-regexp ""))
3688 (string-to-number
3689 (table--read-from-minibuffer '("Number of columns" . table-capture-columns-history)))
3690 nil)
3692 (if (> beg end) (let ((tmp beg)) (setq beg end) (setq end tmp)))
3693 (if (string= col-delim-regexp "") (setq col-delim-regexp nil))
3694 (if (string= row-delim-regexp "") (setq row-delim-regexp nil))
3695 (if (and columns (< columns 1)) (setq columns nil))
3696 (unless min-cell-width (setq min-cell-width "5"))
3697 (let ((contents (buffer-substring beg end))
3698 (cols 0) (rows 0) c r cell-list
3699 (delim-pattern
3700 (if (and col-delim-regexp row-delim-regexp)
3701 (format "\\(\\(%s\\)?\\s *\\(%s\\)\\s *\\)\\|\\(\\(%s\\)\\s *\\)"
3702 col-delim-regexp row-delim-regexp col-delim-regexp)
3703 (if col-delim-regexp
3704 (format "\\(\\)\\(\\)\\(\\)\\(\\(%s\\)\\s *\\)" col-delim-regexp))))
3705 (contents-list))
3706 ;; when delimiters are specified extract cells and determine the cell dimension
3707 (if delim-pattern
3708 (with-temp-buffer
3709 (insert contents)
3710 ;; make sure the contents ends with a newline
3711 (goto-char (point-max))
3712 (unless (zerop (current-column))
3713 (insert ?\n))
3714 ;; skip the preceding white spaces
3715 (goto-char (point-min))
3716 (if (looking-at "\\s +")
3717 (goto-char (match-end 0)))
3718 ;; extract cell contents
3719 (let ((from (point)))
3720 (setq cell-list nil)
3721 (setq c 0)
3722 (while (and (re-search-forward delim-pattern nil t)
3723 (cond
3724 ;; row delimiter
3725 ((and (match-string 1) (not (string= (match-string 1) "")))
3726 (setq rows (1+ rows))
3727 (setq cell-list
3728 (append cell-list (list (buffer-substring from (match-beginning 1)))))
3729 (setq from (match-end 1))
3730 (setq contents-list
3731 (append contents-list (list cell-list)))
3732 (setq cell-list nil)
3733 (setq c (1+ c))
3734 (if (> c cols) (setq cols c))
3735 (setq c 0)
3737 ;; column delimiter
3738 ((and (match-string 4) (not (string= (match-string 4) "")))
3739 (setq cell-list
3740 (append cell-list (list (buffer-substring from (match-beginning 4)))))
3741 (setq from (match-end 4))
3742 (setq c (1+ c))
3743 (if (> c cols) (setq cols c))
3745 (t nil))))
3746 ;; take care of the last element without a post delimiter
3747 (unless (null (looking-at ".+$"))
3748 (setq cell-list
3749 (append cell-list (list (match-string 0))))
3750 (setq cols (1+ cols)))
3751 ;; take care of the last row without a terminating delimiter
3752 (unless (null cell-list)
3753 (setq rows (1+ rows))
3754 (setq contents-list
3755 (append contents-list (list cell-list)))))))
3756 ;; finalize the table dimension
3757 (if (and columns contents-list)
3758 ;; when number of columns are specified and cells are parsed determine the dimension
3759 (progn
3760 (setq cols columns)
3761 (setq rows (/ (+ (length (car contents-list)) columns -1) columns)))
3762 ;; when dimensions are not specified default to a single cell table
3763 (if (zerop rows) (setq rows 1))
3764 (if (zerop cols) (setq cols 1)))
3765 ;; delete the region and reform line breaks
3766 (delete-region beg end)
3767 (goto-char beg)
3768 (unless (zerop (current-column))
3769 (insert ?\n))
3770 (unless (looking-at "\\s *$")
3771 (save-excursion
3772 (insert ?\n)))
3773 ;; insert the table
3774 ;; insert the cell contents
3775 (if (null contents-list)
3776 ;; single cell
3777 (let ((width) (height))
3778 (with-temp-buffer
3779 (insert contents)
3780 (table--remove-eol-spaces (point-min) (point-max))
3781 (table--untabify (point-min) (point-max))
3782 (setq width (table--measure-max-width))
3783 (setq height (1+ (table--current-line (point-max))))
3784 (setq contents (buffer-substring (point-min) (point-max))))
3785 (table-insert cols rows width height)
3786 (table-with-cache-buffer
3787 (insert contents)
3788 (setq table-inhibit-auto-fill-paragraph t)))
3789 ;; multi cells
3790 (table-insert cols rows min-cell-width 1)
3791 (setq r 0)
3792 (setq cell-list nil)
3793 (while (< r rows)
3794 (setq r (1+ r))
3795 (setq c 0)
3796 (unless cell-list
3797 (setq cell-list (car contents-list))
3798 (setq contents-list (cdr contents-list)))
3799 (while (< c cols)
3800 (setq c (1+ c))
3801 (if (car cell-list)
3802 (table-with-cache-buffer
3803 (insert (car cell-list))
3804 (setq cell-list (cdr cell-list))
3805 (setq table-cell-info-justify justify)))
3806 (table-forward-cell 1))))))
3808 ;;;###autoload
3809 (defun table-release ()
3810 "Convert a table into plain text by removing the frame from a table.
3811 Remove the frame from a table and deactivate the table. This command
3812 converts a table into plain text without frames. It is a companion to
3813 `table-capture' which does the opposite process."
3814 (interactive)
3815 (let ((origin-cell (table--probe-cell))
3816 table-lu table-rb)
3817 (if origin-cell
3818 (let ((old-point (point-marker)))
3819 ;; save-excursion is not sufficient for this
3820 ;; because untabify operation moves point
3821 (set-marker-insertion-type old-point t)
3822 (unwind-protect
3823 (progn
3824 (while
3825 (progn
3826 (table-forward-cell 1 nil 'unrecognize)
3827 (let ((cell (table--probe-cell)))
3828 (if (or (null table-lu)
3829 (< (car cell) table-lu))
3830 (setq table-lu (car cell)))
3831 (if (or (null table-rb)
3832 (> (cdr cell) table-rb))
3833 (setq table-rb (cdr cell)))
3834 (and cell (not (equal cell origin-cell))))))
3835 (let* ((lu-coord (table--get-coordinate table-lu))
3836 (rb-coord (table--get-coordinate table-rb))
3837 (lu (table--goto-coordinate (table--offset-coordinate lu-coord '(-1 . -1)))))
3838 (table--spacify-frame)
3839 (setcdr rb-coord (1+ (cdr rb-coord)))
3840 (delete-rectangle lu (table--goto-coordinate (cons (car lu-coord) (cdr rb-coord))))
3841 (table--remove-eol-spaces
3842 (table--goto-coordinate (cons 0 (1- (cdr lu-coord))))
3843 (table--goto-coordinate rb-coord) nil t)))
3844 (goto-char old-point))))))
3846 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3848 ;; Worker functions (executed implicitly)
3851 (defun table--make-cell-map ()
3852 "Make the table cell keymap if it does not exist yet."
3853 ;; This is irrelevant to keymap but good place to make sure to be executed.
3854 (table--update-cell-face)
3855 (unless table-cell-map
3856 (let ((map (make-sparse-keymap)))
3857 ;; `table-command-prefix' mode specific bindings.
3858 (if (vectorp table-command-prefix)
3859 (dolist (binding table-cell-bindings)
3860 (let ((seq (copy-sequence (car binding))))
3861 (and (vectorp seq)
3862 (listp (aref seq 0))
3863 (eq (car (aref seq 0)) 'control)
3864 (progn
3865 (aset seq 0 (cadr (aref seq 0)))
3866 (define-key map (vconcat table-command-prefix seq)
3867 (cdr binding)))))))
3868 ;; Shorthand control bindings.
3869 (dolist (binding table-cell-bindings)
3870 (define-key map (car binding) (cdr binding)))
3871 ;; Remap normal commands to table specific version.
3872 (dolist (remap table-command-remap-alist)
3873 (define-key map (vector 'remap (car remap)) (cdr remap)))
3875 (setq table-cell-map map)
3876 (fset 'table-cell-map map)))
3877 ;; Add menu for table cells.
3878 (unless table-disable-menu
3879 (easy-menu-define table-cell-menu-map table-cell-map
3880 "Table cell menu" table-cell-menu)
3881 (if (featurep 'xemacs)
3882 (easy-menu-add table-cell-menu)))
3883 (run-hooks 'table-cell-map-hook))
3885 ;; Create the keymap after running the user init file so that the user
3886 ;; modification to the global-map is accounted.
3887 (add-hook 'after-init-hook 'table--make-cell-map t)
3889 (defun *table--cell-self-insert-command ()
3890 "Table cell version of `self-insert-command'."
3891 (interactive "*")
3892 (let ((char last-command-event))
3893 (if (eq buffer-undo-list t) nil
3894 (if (not (eq last-command this-command))
3895 (setq table-cell-self-insert-command-count 0)
3896 (if (car buffer-undo-list) nil
3897 (if (>= table-cell-self-insert-command-count 19)
3898 (setq table-cell-self-insert-command-count 0)
3899 (setq buffer-undo-list (cdr buffer-undo-list))
3900 (setq table-cell-self-insert-command-count (1+ table-cell-self-insert-command-count))))))
3901 (table--cell-insert-char char overwrite-mode)))
3903 (defun *table--cell-delete-backward-char (n)
3904 "Table cell version of `delete-backward-char'."
3905 (interactive "*p")
3906 (*table--cell-delete-char (- n)))
3908 (defun *table--cell-newline (&optional indent)
3909 "Table cell version of `newline'."
3910 (interactive "*")
3911 (table-with-cache-buffer
3912 (let ((column (current-column)))
3913 (insert ?\n)
3914 (if indent (indent-to-column column))
3915 ;; fill only when at the beginning of paragraph
3916 (if (= (point)
3917 (save-excursion
3918 (forward-paragraph -1)
3919 (if (looking-at "\\s *$")
3920 (forward-line 1))
3921 (point)))
3922 nil ; yes, at the beginning of the paragraph
3923 (setq table-inhibit-auto-fill-paragraph t)))))
3925 (defun *table--cell-open-line (n)
3926 "Table cell version of `open-line'."
3927 (interactive "*p")
3928 (table-with-cache-buffer
3929 (save-excursion
3930 (insert (make-string n ?\n))
3931 (table--fill-region (point) (point))
3932 (setq table-inhibit-auto-fill-paragraph t))))
3934 (defun *table--cell-newline-and-indent ()
3935 "Table cell version of `newline-and-indent'."
3936 (interactive)
3937 (*table--cell-newline t))
3939 (defun *table--cell-delete-char (n)
3940 "Table cell version of `delete-char'."
3941 (interactive "*p")
3942 (let ((overwrite overwrite-mode))
3943 (table-with-cache-buffer
3944 (if (and overwrite (< n 0))
3945 (progn
3946 (while (not (zerop n))
3947 (let ((coordinate (table--get-coordinate)))
3948 (if (zerop (car coordinate))
3949 (unless (zerop (cdr coordinate))
3950 (table--goto-coordinate (cons (1- table-cell-info-width) (1- (cdr coordinate))))
3951 (unless (eolp)
3952 (delete-char 1)))
3953 (delete-char -1)
3954 (insert ?\s)
3955 (forward-char -1)))
3956 (setq n (1+ n)))
3957 (setq table-inhibit-auto-fill-paragraph t))
3958 (let ((coordinate (table--get-coordinate))
3959 (end-marker (copy-marker (+ (point) n)))
3960 (deleted))
3961 (if (or (< end-marker (point-min))
3962 (> end-marker (point-max))) nil
3963 (table--remove-eol-spaces (point-min) (point-max))
3964 (setq deleted (buffer-substring (point) end-marker))
3965 (delete-char n)
3966 ;; in fixed width mode when two lines are concatenated
3967 ;; remove continuation character if there is one.
3968 (and table-fixed-width-mode
3969 (string-match "^\n" deleted)
3970 (equal (char-before) table-word-continuation-char)
3971 (delete-char -2))
3972 ;; see if the point is placed at the right tip of the previous
3973 ;; blank line, if so get rid of the preceding blanks.
3974 (if (and (not (bolp))
3975 (/= (cdr coordinate) (cdr (table--get-coordinate)))
3976 (let ((end (point)))
3977 (save-excursion
3978 (beginning-of-line)
3979 (re-search-forward "\\s +" end t)
3980 (= (point) end))))
3981 (replace-match ""))
3982 ;; do not fill the paragraph if the point is already at the end
3983 ;; of this paragraph and is following a blank character
3984 ;; (otherwise the filling squeezes the preceding blanks)
3985 (if (and (looking-at "\\s *$")
3986 (or (bobp)
3987 (save-excursion
3988 (backward-char)
3989 (looking-at "\\s "))))
3990 (setq table-inhibit-auto-fill-paragraph t))
3992 (set-marker end-marker nil))))))
3994 (defun *table--cell-quoted-insert (arg)
3995 "Table cell version of `quoted-insert'."
3996 (interactive "*p")
3997 (let ((char (read-quoted-char)))
3998 (while (> arg 0)
3999 (table--cell-insert-char char nil)
4000 (setq arg (1- arg)))))
4002 (defun *table--cell-describe-mode ()
4003 "Table cell version of `describe-mode'."
4004 (interactive)
4005 (if (not (table--point-in-cell-p))
4006 (call-interactively 'describe-mode)
4007 (with-output-to-temp-buffer "*Help*"
4008 (princ "Table mode: (in ")
4009 (princ (format-mode-line mode-name nil nil (current-buffer)))
4010 (princ " mode)
4012 Table is not a mode technically. You can regard it as a pseudo mode
4013 which exists locally within a buffer. It overrides some standard
4014 editing behaviors. Editing operations in a table produces confined
4015 effects to the current cell. It may grow the cell horizontally and/or
4016 vertically depending on the newly entered or deleted contents of the
4017 cell, and also depending on the current mode of cell.
4019 In the normal mode the table preserves word continuity. Which means
4020 that a word never gets folded into multiple lines. For this purpose
4021 table will occasionally grow the cell width. On the other hand, when
4022 in a fixed width mode all cell width are fixed. When a word can not
4023 fit in the cell width the word is folded into the next line. The
4024 folded location is marked by a continuation character which is
4025 specified in the variable `table-word-continuation-char'.
4027 (help-print-return-message))))
4029 (defun *table--cell-describe-bindings ()
4030 "Table cell version of `describe-bindings'."
4031 (interactive)
4032 (if (not (table--point-in-cell-p))
4033 (call-interactively 'describe-bindings)
4034 (with-output-to-temp-buffer "*Help*"
4035 (princ "Table Bindings:
4036 key binding
4037 --- -------
4040 (mapc (lambda (binding)
4041 (princ (format "%-16s%s\n"
4042 (key-description (car binding))
4043 (cdr binding))))
4044 table-cell-bindings)
4045 (help-print-return-message))))
4047 (defvar dabbrev-abbrev-char-regexp)
4049 (defun *table--cell-dabbrev-expand (arg)
4050 "Table cell version of `dabbrev-expand'."
4051 (interactive "*P")
4052 (let ((dabbrev-abbrev-char-regexp (concat "[^"
4053 (char-to-string table-cell-vertical-char)
4054 (char-to-string table-cell-intersection-char)
4055 " \n]")))
4056 (table-with-cache-buffer
4057 (dabbrev-expand arg))))
4059 (defun *table--cell-dabbrev-completion (&optional arg)
4060 "Table cell version of `dabbrev-completion'."
4061 (interactive "*P")
4062 (error "`dabbrev-completion' is incompatible with table")
4063 (let ((dabbrev-abbrev-char-regexp (concat "[^"
4064 (char-to-string table-cell-vertical-char)
4065 (char-to-string table-cell-intersection-char)
4066 " \n]")))
4067 (table-with-cache-buffer
4068 (dabbrev-completion arg))))
4070 (defun *table--present-cell-popup-menu (event)
4071 "Present and handle cell popup menu."
4072 (interactive "e")
4073 (unless table-disable-menu
4074 (select-window (posn-window (event-start event)))
4075 (goto-char (posn-point (event-start event)))
4076 (let ((item-list (x-popup-menu event table-cell-menu-map))
4077 (func table-cell-menu-map))
4078 (while item-list
4079 (setq func (nth 3 (assoc (car item-list) func)))
4080 (setq item-list (cdr item-list)))
4081 (if (and (symbolp func) (fboundp func))
4082 (call-interactively func)))))
4084 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4086 ;; Cell updating functions
4089 (defun table--update-cell (&optional now)
4090 "Update the table cell contents.
4091 When the optional parameter NOW is nil it only sets up the update
4092 timer. If it is non-nil the function copies the contents of the cell
4093 cache buffer into the designated cell in the table buffer."
4094 (if (null table-update-timer) nil
4095 (table--cancel-timer table-update-timer)
4096 (setq table-update-timer nil))
4097 (if (or (not now)
4098 (and (boundp 'quail-converting)
4099 quail-converting) ;; defer operation while current quail work is not finished.
4100 (and (boundp 'quail-translating)
4101 quail-translating))
4102 (setq table-update-timer
4103 (table--set-timer table-time-before-update
4104 (function table--update-cell)
4105 'now))
4106 (save-current-buffer
4107 (set-buffer table-cell-buffer)
4108 (let ((cache-buffer (get-buffer-create table-cache-buffer-name))
4109 (org-coord (table--get-coordinate))
4110 (in-cell (equal (table--cell-to-coord (table--probe-cell))
4111 (cons table-cell-info-lu-coordinate table-cell-info-rb-coordinate)))
4112 rectangle)
4113 (set-buffer cache-buffer)
4114 (setq rectangle
4115 (extract-rectangle
4117 (table--goto-coordinate (cons table-cell-info-width (1- table-cell-info-height)))))
4118 (set-buffer table-cell-buffer)
4119 (delete-rectangle (table--goto-coordinate table-cell-info-lu-coordinate)
4120 (table--goto-coordinate table-cell-info-rb-coordinate))
4121 (table--goto-coordinate table-cell-info-lu-coordinate)
4122 (table--insert-rectangle rectangle)
4123 (let* ((cell (table--probe-cell))) ; must probe again in case of wide characters
4124 (table--put-cell-property cell)
4125 (table--put-cell-justify-property cell table-cell-info-justify)
4126 (table--put-cell-valign-property cell table-cell-info-valign))
4127 (table--goto-coordinate
4128 (if in-cell
4129 (table--transcoord-cache-to-table table-cell-cache-point-coordinate)
4130 org-coord))))
4131 ;; simulate undo behavior under overwrite-mode
4132 (if (and overwrite-mode (not (eq buffer-undo-list t)))
4133 (setq buffer-undo-list (cons nil buffer-undo-list)))))
4135 (defun table--update-cell-widened (&optional now)
4136 "Update the contents of the cells that are affected by widening operation."
4137 (if (null table-widen-timer) nil
4138 (table--cancel-timer table-widen-timer)
4139 (setq table-widen-timer nil))
4140 (if (not now)
4141 (setq table-widen-timer
4142 (table--set-timer (+ table-time-before-update table-time-before-reformat)
4143 (function table--update-cell-widened)
4144 'now))
4145 (save-current-buffer
4146 (if table-update-timer
4147 (table--update-cell 'now))
4148 (set-buffer table-cell-buffer)
4149 (let* ((current-coordinate (table--get-coordinate))
4150 (current-cell-coordinate (table--cell-to-coord (table--probe-cell)))
4151 (cell-coord-list (progn
4152 (table--goto-coordinate table-cell-info-lu-coordinate)
4153 (table--cell-list-to-coord-list (table--vertical-cell-list)))))
4154 (while cell-coord-list
4155 (let* ((cell-coord (prog1 (car cell-coord-list) (setq cell-coord-list (cdr cell-coord-list))))
4156 (currentp (equal cell-coord current-cell-coordinate)))
4157 (if currentp (table--goto-coordinate current-coordinate)
4158 (table--goto-coordinate (car cell-coord)))
4159 (table-recognize-cell 'froce)
4160 (let ((table-inhibit-update t))
4161 (table-with-cache-buffer
4162 (let ((sticky (and currentp
4163 (save-excursion
4164 (unless (bolp) (forward-char -1))
4165 (looking-at ".*\\S ")))))
4166 (table--fill-region (point-min) (point-max))
4167 (if sticky
4168 (setq current-coordinate (table--transcoord-cache-to-table))))))
4169 (table--update-cell 'now)
4171 (table--goto-coordinate current-coordinate)
4172 (table-recognize-cell 'froce)))))
4174 (defun table--update-cell-heightened (&optional now)
4175 "Update the contents of the cells that are affected by heightening operation."
4176 (if (null table-heighten-timer) nil
4177 (table--cancel-timer table-heighten-timer)
4178 (setq table-heighten-timer nil))
4179 (if (not now)
4180 (setq table-heighten-timer
4181 (table--set-timer (+ table-time-before-update table-time-before-reformat)
4182 (function table--update-cell-heightened)
4183 'now))
4184 (save-current-buffer
4185 (if table-update-timer
4186 (table--update-cell 'now))
4187 (if table-widen-timer
4188 (table--update-cell-widened 'now))
4189 (set-buffer table-cell-buffer)
4190 (let* ((current-coordinate (table--get-coordinate))
4191 (current-cell-coordinate (table--cell-to-coord (table--probe-cell)))
4192 (cell-coord-list (progn
4193 (table--goto-coordinate table-cell-info-lu-coordinate)
4194 (table--cell-list-to-coord-list (table--horizontal-cell-list)))))
4195 (while cell-coord-list
4196 (let* ((cell-coord (prog1 (car cell-coord-list) (setq cell-coord-list (cdr cell-coord-list))))
4197 (currentp (equal cell-coord current-cell-coordinate)))
4198 (if currentp (table--goto-coordinate current-coordinate)
4199 (table--goto-coordinate (car cell-coord)))
4200 (table-recognize-cell 'froce)
4201 (let ((table-inhibit-update t))
4202 (table-with-cache-buffer
4203 (let ((sticky (and currentp
4204 (save-excursion
4205 (unless (bolp) (forward-char -1))
4206 (looking-at ".*\\S ")))))
4207 (table--valign)
4208 (if sticky
4209 (setq current-coordinate (table--transcoord-cache-to-table))))))
4210 (table--update-cell 'now)
4212 (table--goto-coordinate current-coordinate)
4213 (table-recognize-cell 'froce)))))
4215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4217 ;; Service functions (for external packages)
4220 (defun table-goto-top-left-corner ()
4221 "Move point to top left corner of the current table and return the char position."
4222 (table--goto-coordinate
4223 (cons
4224 (1- (car (table--get-coordinate (car (table--horizontal-cell-list t t)))))
4225 (1- (cdr (table--get-coordinate (car (table--vertical-cell-list t t))))))))
4227 (defun table-goto-top-right-corner ()
4228 "Move point to top right corner of the current table and return the char position."
4229 (table--goto-coordinate
4230 (cons
4231 (car (table--get-coordinate (cdr (table--horizontal-cell-list nil t))))
4232 (1- (cdr (table--get-coordinate (car (table--vertical-cell-list t t))))))))
4234 (defun table-goto-bottom-left-corner ()
4235 "Move point to bottom left corner of the current table and return the char position."
4236 (table--goto-coordinate
4237 (cons
4238 (1- (car (table--get-coordinate (car (table--horizontal-cell-list t t)))))
4239 (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))))
4241 (defun table-goto-bottom-right-corner ()
4242 "Move point to bottom right corner of the current table and return the char position."
4243 (table--goto-coordinate
4244 (cons
4245 (car (table--get-coordinate (cdr (table--horizontal-cell-list nil t))))
4246 (1+ (cdr (table--get-coordinate (cdr (table--vertical-cell-list nil t))))))))
4248 (defun table-function (function)
4249 ;; FIXME: Apparently unused. There used to be table-funcall, table-apply,
4250 ;; and table-call-interactively instead, neither of which seemed to be
4251 ;; used either.
4252 "Return FUNCTION, or a table version of it if applicable."
4253 (let ((table-func (intern-soft (format "*table--cell-%s" function))))
4254 (if (and table-func
4255 (table--point-in-cell-p))
4256 table-func
4257 function)))
4259 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4261 ;; Utility functions
4264 (defun table--read-from-minibuffer (prompt-history)
4265 "A wrapper to `read-from-minibuffer'.
4266 PROMPT-HISTORY is a cons cell which car is the prompt string and the
4267 cdr is the history symbol."
4268 (let ((default (car (symbol-value (cdr prompt-history)))))
4269 (read-from-minibuffer
4270 (format "%s (default %s): " (car prompt-history) default)
4271 "" nil nil (cdr prompt-history) default))
4272 (and (featurep 'xemacs)
4273 (equal (car (symbol-value (cdr prompt-history))) "")
4274 (set (cdr prompt-history)
4275 (cdr (symbol-value (cdr prompt-history)))))
4276 (car (symbol-value (cdr prompt-history))))
4278 (defun table--buffer-substring-and-trim (beg end)
4279 "Extract buffer substring and remove blanks from front and the rear of it."
4280 (save-excursion
4281 (save-restriction
4282 (narrow-to-region (goto-char beg) end)
4283 (if (re-search-forward "\\s *")
4284 (setq beg (match-end 0)))
4285 (if (re-search-forward "\\s *\\'" end t)
4286 (setq end (match-beginning 0)))
4287 (table--remove-cell-properties
4288 0 (- end beg)
4289 (buffer-substring beg end)))))
4291 (defun table--valign ()
4292 "Vertically align the cache cell contents.
4293 Current buffer must be the cache buffer at the entry to this function.
4294 Returns the coordinate of the final point location."
4295 (if (or (null table-cell-info-valign)
4296 (eq table-cell-info-valign 'none))
4297 (table--get-coordinate)
4298 (let ((saved-point (point-marker)))
4299 ;;(set-marker-insertion-type saved-point t)
4300 (goto-char (point-min))
4301 (let* ((from (and (re-search-forward "^.*\\S " nil t)
4302 (table--current-line)))
4303 (to (let ((tmp from))
4304 (while (re-search-forward "^.*\\S " nil t)
4305 (setq tmp (table--current-line)))
4306 tmp))
4307 (content-height (and from to (1+ (- to from)))))
4308 (unless (null content-height)
4309 (goto-char (point-min))
4310 (if (looking-at "\\s *\n")
4311 (replace-match ""))
4312 (cond ((eq table-cell-info-valign 'middle)
4313 (insert (make-string (/ (- table-cell-info-height content-height) 2) ?\n)))
4314 ((eq table-cell-info-valign 'bottom)
4315 (insert (make-string (- table-cell-info-height content-height) ?\n))))
4316 (table--goto-coordinate (cons table-cell-info-width (1- table-cell-info-height)))
4317 (if (re-search-forward "\\s +\\'" nil t)
4318 (replace-match ""))))
4319 (goto-char saved-point)
4320 (set-marker saved-point nil)
4321 (let ((coord (table--get-coordinate)))
4322 (unless (< (cdr coord) table-cell-info-height)
4323 (setcdr coord (1- table-cell-info-height))
4324 (table--goto-coordinate coord))
4325 coord))))
4327 (defun table--query-justification ()
4328 (barf-if-buffer-read-only)
4329 (let* ((completion-ignore-case t)
4330 (default (car table-justify-history)))
4331 (intern (downcase (completing-read
4332 (format "Justify (default %s): " default)
4333 '(("left") ("center") ("right") ("top") ("middle") ("bottom") ("none"))
4334 nil t nil 'table-justify-history default)))))
4336 (defun table--spacify-frame ()
4337 "Spacify table frame.
4338 Replace frame characters with spaces."
4339 (let ((frame-char
4340 (append (string-to-list table-cell-horizontal-chars)
4341 (list table-cell-intersection-char table-cell-vertical-char))))
4342 (while
4343 (progn
4344 (cond
4345 ((eq (char-after) table-cell-intersection-char)
4346 (save-excursion
4347 (let ((col (current-column)))
4348 (and (zerop (forward-line 1))
4349 (zerop (current-column))
4350 (move-to-column col)
4351 (table--spacify-frame))))
4352 (delete-char 1)
4353 (insert-before-markers ?\s))
4354 ((table--cell-horizontal-char-p (char-after))
4355 (while (progn
4356 (delete-char 1)
4357 (insert-before-markers ?\s)
4358 (table--cell-horizontal-char-p (char-after)))))
4359 ((eq (char-after) table-cell-vertical-char)
4360 (while (let ((col (current-column)))
4361 (delete-char 1)
4362 (insert-before-markers ?\s)
4363 (and (zerop (forward-line 1))
4364 (zerop (current-column))
4365 (move-to-column col)
4366 (eq (char-after) table-cell-vertical-char))))))
4367 (memq (char-after) frame-char)))))
4369 (defun table--remove-blank-lines (n)
4370 "Delete N blank lines from the current line.
4371 For adjusting below area of the table when the table is shortened."
4372 (move-to-column 0)
4373 (let ((first-blank t))
4374 (while (> n 0)
4375 (setq n (1- n))
4376 (cond ((looking-at "\\s *\\'")
4377 (delete-region (match-beginning 0) (match-end 0))
4378 (setq n 0))
4379 ((and (looking-at "\\([ \t]*\n[ \t]*\\)\n") first-blank)
4380 (delete-region (match-beginning 1) (match-end 1)))
4381 ((looking-at "[ \t]*$")
4382 (delete-region (match-beginning 0) (match-end 0))
4383 (forward-line 1))
4385 (setq first-blank nil)
4386 (forward-line 1))))))
4388 (defun table--uniform-list-p (l)
4389 "Return nil when LIST contains non equal elements. Otherwise return t."
4390 (if (null l) t
4391 (catch 'end
4392 (while (cdr l)
4393 (if (not (equal (car l) (cadr l))) (throw 'end nil))
4394 (setq l (cdr l)))
4395 t)))
4397 (defun table--detect-cell-alignment (cell)
4398 "Detect CELL contents alignment.
4399 Guess CELL contents alignment both horizontally and vertically by
4400 looking at the appearance of the CELL contents."
4401 (let ((cell-contents (extract-rectangle (car cell) (cdr cell)))
4402 (left-margin 0)
4403 (right-margin 0)
4404 (top-margin 0)
4405 (bottom-margin 0)
4406 (margin-diff 0)
4407 (margin-info-available nil)
4408 justify valign)
4409 (with-temp-buffer
4410 (table--insert-rectangle cell-contents)
4411 ;; determine the horizontal justification
4412 (goto-char (point-min))
4413 (while (re-search-forward "^\\( *\\).*[^ \n]\\( *\\)$" nil t)
4414 (setq margin-info-available t)
4415 (let* ((lm (- (match-end 1) (match-beginning 1)))
4416 (rm (- (match-end 2) (match-beginning 2)))
4417 (md (abs (- lm rm))))
4418 (if (> lm left-margin)
4419 (setq left-margin lm))
4420 (if (> rm right-margin)
4421 (setq right-margin rm))
4422 (if (> md margin-diff)
4423 (setq margin-diff md))))
4424 (setq justify
4425 (cond
4426 ((and margin-info-available
4427 (<= margin-diff 1)
4428 (> left-margin 0)) 'center)
4429 ((and margin-info-available
4430 (zerop right-margin)
4431 (> left-margin 0)) 'right)
4432 (t 'left)))
4433 ;; determine the vertical justification
4434 (goto-char (point-min))
4435 (if (and (re-search-forward "\\s *\\S " nil t)
4436 (/= (match-beginning 0) (match-end 0)))
4437 (setq top-margin (1- (count-lines (match-beginning 0) (match-end 0)))))
4438 (if (and (re-search-forward "\\s *\\'" nil t)
4439 (/= (match-beginning 0) (match-end 0)))
4440 (setq bottom-margin (1- (count-lines (match-beginning 0) (match-end 0)))))
4441 (setq valign
4442 (cond
4443 ((and (> top-margin 0)
4444 (> bottom-margin 0)
4445 (<= (abs (- top-margin bottom-margin)) 1)) 'middle)
4446 ((and (> top-margin 0)
4447 (zerop bottom-margin)) 'bottom)
4448 (t nil))))
4449 (table--put-cell-justify-property cell justify)
4450 (table--put-cell-valign-property cell valign)))
4452 (defun table--string-to-number-list (str)
4453 "Return a list of numbers in STR."
4454 (let ((idx 0)
4455 (nl nil))
4456 (while (string-match "[-0-9.]+" str idx)
4457 (setq idx (match-end 0))
4458 (setq nl (cons (string-to-number (match-string 0 str)) nl)))
4459 (nreverse nl)))
4461 (defun table--justify-cell-contents (justify &optional paragraph)
4462 "Justify the current cell contents.
4463 JUSTIFY is a symbol 'left, 'center or 'right for horizontal, or 'top,
4464 'middle, 'bottom or 'none for vertical. When PARAGRAPH is non-nil the
4465 justify operation is limited to the current paragraph."
4466 (table-with-cache-buffer
4467 (let ((beg (point-min))
4468 (end (point-max-marker))
4469 (fill-column table-cell-info-width)
4470 (adaptive-fill-mode nil)
4471 (valign-symbols '(top middle bottom none)))
4472 (unless paragraph
4473 (if (memq justify valign-symbols)
4474 (setq table-cell-info-valign
4475 (if (eq justify 'none) nil justify))
4476 (setq table-cell-info-justify justify)))
4477 (save-excursion
4478 (if paragraph
4479 (let ((paragraph-start "\n"))
4480 (forward-paragraph)
4481 (or (bolp) (newline 1))
4482 (set-marker end (point))
4483 (setq beg (progn (forward-paragraph -1) (point)))))
4484 (if (memq justify valign-symbols)
4485 (table--valign)
4486 (table--remove-eol-spaces beg end 'bol)
4487 (let ((paragraph-start table-paragraph-start))
4488 (fill-region beg end table-cell-info-justify))))
4489 (setq table-inhibit-auto-fill-paragraph t)
4490 (set-marker end nil)))
4491 (table--update-cell 'now))
4493 (defun table--horizontally-shift-above-and-below (columns-to-extend top-to-bottom-coord-list)
4494 "Horizontally shift outside contents right above and right below of the table.
4495 This function moves the surrounding text outside of the table so that
4496 they match the horizontal growth/shrink of the table. It also
4497 untabify the shift affected area including the right side of the table
4498 so that tab related uneven shifting is avoided. COLUMNS-TO-EXTEND
4499 specifies the number of columns the table grows, or shrinks if
4500 negative. TOP-TO-BOTTOM-COORD-LIST is the vertical cell coordinate
4501 list. This list can be any vertical list within the table."
4502 (save-excursion
4503 (let (beg-coord end-coord)
4504 (table--goto-coordinate (caar top-to-bottom-coord-list))
4505 (let* ((cell (table--horizontal-cell-list nil 'first-only 'top))
4506 (coord (cons (car (table--get-coordinate (cdr cell)))
4507 (cdr (table--get-coordinate (car cell))))))
4508 (setcar coord (1+ (car coord)))
4509 (setcdr coord (- (cdr coord) 2))
4510 (setq beg-coord (cons (car coord) (1+ (cdr coord))))
4511 (while (and (table--goto-coordinate coord 'no-extension)
4512 (not (looking-at "\\s *$")))
4513 (if (< columns-to-extend 0)
4514 (progn
4515 (table--untabify-line)
4516 (delete-char columns-to-extend))
4517 (table--untabify-line (point))
4518 (insert (make-string columns-to-extend ?\s)))
4519 (setcdr coord (1- (cdr coord)))))
4520 (table--goto-coordinate (caar (last top-to-bottom-coord-list)))
4521 (let ((coord (table--get-coordinate (cdr (table--horizontal-cell-list nil 'first-only 'bottom)))))
4522 (setcar coord (1+ (car coord)))
4523 (setcdr coord (+ (cdr coord) 2))
4524 (setq end-coord (cons (car coord) (1- (cdr coord))))
4525 (while (and (table--goto-coordinate coord 'no-extension)
4526 (not (looking-at "\\s *$")))
4527 (if (< columns-to-extend 0)
4528 (progn
4529 (table--untabify-line)
4530 (delete-char columns-to-extend))
4531 (table--untabify-line (point))
4532 (insert (make-string columns-to-extend ?\s)))
4533 (setcdr coord (1+ (cdr coord)))))
4534 (while (<= (cdr beg-coord) (cdr end-coord))
4535 (table--untabify-line (table--goto-coordinate beg-coord 'no-extension))
4536 (setcdr beg-coord (1+ (cdr beg-coord)))))))
4538 (defun table--create-growing-space-below (lines-to-extend left-to-right-coord-list bottom-border-y)
4539 "Create growing space below the table.
4540 This function creates growing space below the table slightly
4541 intelligent fashion. Following is the cases it handles for each
4542 growing line:
4543 1. When the first line below the table is a complete blank line it
4544 inserts a blank line.
4545 2. When the line starts with a prefix that matches the prefix of the
4546 bottom line of the table it inserts a line consisting of prefix alone.
4547 3. Otherwise it deletes the rectangular contents where table will
4548 grow into."
4549 (save-excursion
4550 (let ((i 0)
4551 (prefix (and (table--goto-coordinate (cons 0 bottom-border-y))
4552 (re-search-forward
4553 ".*\\S "
4554 (save-excursion
4555 (table--goto-coordinate
4556 (cons (1- (caar (car left-to-right-coord-list))) bottom-border-y)))
4558 (buffer-substring (match-beginning 0) (match-end 0)))))
4559 (while (< i lines-to-extend)
4560 (let ((y (+ i bottom-border-y 1)))
4561 (table--goto-coordinate (cons 0 y))
4562 (cond
4563 ((looking-at "\\s *$")
4564 (insert ?\n))
4565 ((and prefix (looking-at (concat (regexp-quote prefix) "\\s *$")))
4566 (insert prefix ?\n))
4568 (delete-rectangle
4569 (table--goto-coordinate (cons (1- (caar (car left-to-right-coord-list))) y))
4570 (table--goto-coordinate (cons (1+ (cadr (car (last left-to-right-coord-list)))) y))))))
4571 (setq i (1+ i))))))
4573 (defun table--untabify-line (&optional from)
4574 "Untabify current line.
4575 Unlike save-excursion this guarantees preserving the cursor location
4576 even when the point is on a tab character which is to be removed.
4577 Optional FROM narrows the subject operation from this point to the end
4578 of line."
4579 (let ((current-coordinate (table--get-coordinate)))
4580 (table--untabify (or from (progn (beginning-of-line) (point)))
4581 (progn (end-of-line) (point)))
4582 (table--goto-coordinate current-coordinate)))
4584 (defun table--untabify (beg end)
4585 "Wrapper to raw untabify."
4586 (untabify beg end)
4587 (if (featurep 'xemacs)
4588 ;; Cancel strange behavior of xemacs
4589 (message "")))
4591 (defun table--multiply-string (string multiplier)
4592 "Multiply string and return it."
4593 (let ((ret-str ""))
4594 (while (> multiplier 0)
4595 (setq ret-str (concat ret-str string))
4596 (setq multiplier (1- multiplier)))
4597 ret-str))
4599 (defun table--line-column-position (line column)
4600 "Return the location of LINE forward at COLUMN."
4601 (save-excursion
4602 (forward-line line)
4603 (move-to-column column)
4604 (point)))
4606 (defun table--row-column-insertion-point-p (&optional columnp)
4607 "Return non-nil if it makes sense to insert a row or a column at point."
4608 (and (not buffer-read-only)
4609 (or (get-text-property (point) 'table-cell)
4610 (let ((column (current-column)))
4611 (if columnp
4612 (or (text-property-any (line-beginning-position 0)
4613 (table--line-column-position -1 column)
4614 'table-cell t)
4615 (text-property-any (line-beginning-position) (point) 'table-cell t)
4616 (text-property-any (line-beginning-position 2)
4617 (table--line-column-position 1 column)
4618 'table-cell t))
4619 (text-property-any (table--line-column-position -2 column)
4620 (table--line-column-position -2 (+ 2 column))
4621 'table-cell t))))))
4623 (defun table--find-row-column (&optional columnp no-error)
4624 "Search table and return a cell coordinate list of row or column."
4625 (let ((current-coordinate (table--get-coordinate)))
4626 (catch 'end
4627 (catch 'error
4628 (let ((coord (table--get-coordinate)))
4629 (while
4630 (progn
4631 (if columnp (setcar coord (1- (car coord)))
4632 (setcdr coord (1- (cdr coord))))
4633 (>= (if columnp (car coord) (cdr coord)) 0))
4634 (while (progn
4635 (table--goto-coordinate coord 'no-extension 'no-tab-expansion)
4636 (not (looking-at (format "[%s%c%c]"
4637 table-cell-horizontal-chars
4638 table-cell-vertical-char
4639 table-cell-intersection-char))))
4640 (if columnp (setcar coord (1- (car coord)))
4641 (setcdr coord (1- (cdr coord))))
4642 (if (< (if columnp (car coord) (cdr coord)) 0)
4643 (throw 'error nil)))
4644 (if (table--probe-cell)
4645 (throw 'end (table--cell-list-to-coord-list (if columnp
4646 (table--vertical-cell-list t nil 'left)
4647 (table--horizontal-cell-list t nil 'top))))
4648 (table--goto-coordinate (table--offset-coordinate coord (if columnp '(0 . 1) '(1 . 0)))
4649 'no-extension 'no-tab-expansion)
4650 (if (table--probe-cell)
4651 (throw 'end (table--cell-list-to-coord-list (if columnp
4652 (table--vertical-cell-list t nil 'left)
4653 (table--horizontal-cell-list t nil 'top)))))))))
4654 (table--goto-coordinate current-coordinate)
4655 (if no-error nil
4656 (error "Table not found")))))
4658 (defun table--min-coord-list (coord-list)
4659 "Return minimum cell dimension of COORD-LIST.
4660 COORD-LIST is a list of coordinate pairs (lu-coord . rb-coord), where
4661 each pair in the list represents a cell. lu-coord is the left upper
4662 coordinate of a cell and rb-coord is the right bottom coordinate of a
4663 cell. A coordinate is a pair of x and y axis coordinate values. The
4664 return value is a cons cell (min-w . min-h), where min-w and min-h are
4665 respectively the minimum width and the minimum height of all the cells
4666 in the list."
4667 (if (null coord-list) nil
4668 (let ((min-width 134217727)
4669 (min-height 134217727))
4670 (while coord-list
4671 (let* ((coord (prog1 (car coord-list) (setq coord-list (cdr coord-list))))
4672 (width (- (cadr coord) (caar coord)))
4673 (height (1+ (- (cddr coord) (cdar coord)))))
4674 (if (< width min-width) (setq min-width width))
4675 (if (< height min-height) (setq min-height height))))
4676 (cons min-width min-height))))
4678 (defun table--cell-can-split-horizontally-p ()
4679 "Test if a cell can split at current location horizontally."
4680 (and (not buffer-read-only)
4681 (let ((point-x (car (table--get-coordinate))))
4682 (table-recognize-cell 'force)
4683 (and (> point-x (car table-cell-info-lu-coordinate))
4684 (<= point-x (1- (car table-cell-info-rb-coordinate)))))))
4686 (defun table--cell-can-split-vertically-p ()
4687 "Test if a cell can split at current location vertically."
4688 (and (not buffer-read-only)
4689 (let ((point-y (cdr (table--get-coordinate))))
4690 (table-recognize-cell 'force)
4691 (and (> point-y (cdr table-cell-info-lu-coordinate))
4692 (<= point-y (cdr table-cell-info-rb-coordinate))))))
4694 (defun table--cell-can-span-p (direction)
4695 "Test if the current cell can span to DIRECTION."
4696 (table-recognize-cell 'force)
4697 (and (not buffer-read-only)
4698 (table--probe-cell)
4699 ;; get two adjacent cells from each corner
4700 (let ((cell (save-excursion
4701 (and
4702 (table--goto-coordinate
4703 (cons (cond ((eq direction 'right) (1+ (car table-cell-info-rb-coordinate)))
4704 ((eq direction 'left) (1- (car table-cell-info-lu-coordinate)))
4705 (t (car table-cell-info-lu-coordinate)))
4706 (cond ((eq direction 'above) (- (cdr table-cell-info-lu-coordinate) 2))
4707 ((eq direction 'below) (+ (cdr table-cell-info-rb-coordinate) 2))
4708 (t (cdr table-cell-info-lu-coordinate)))) 'no-extension)
4709 (table--probe-cell))))
4710 (cell2 (save-excursion
4711 (and
4712 (table--goto-coordinate
4713 (cons (cond ((eq direction 'right) (1+ (car table-cell-info-rb-coordinate)))
4714 ((eq direction 'left) (1- (car table-cell-info-lu-coordinate)))
4715 (t (car table-cell-info-rb-coordinate)))
4716 (cond ((eq direction 'above) (- (cdr table-cell-info-lu-coordinate) 2))
4717 ((eq direction 'below) (+ (cdr table-cell-info-rb-coordinate) 2))
4718 (t (cdr table-cell-info-rb-coordinate)))) 'no-extension)
4719 (table--probe-cell)))))
4720 ;; make sure the two cells exist, and they are identical, that cell's size matches the current one
4721 (and cell
4722 (equal cell cell2)
4723 (if (or (eq direction 'right) (eq direction 'left))
4724 (and (= (cdr (table--get-coordinate (car cell)))
4725 (cdr table-cell-info-lu-coordinate))
4726 (= (cdr (table--get-coordinate (cdr cell)))
4727 (cdr table-cell-info-rb-coordinate)))
4728 (and (= (car (table--get-coordinate (car cell)))
4729 (car table-cell-info-lu-coordinate))
4730 (= (car (table--get-coordinate (cdr cell)))
4731 (car table-cell-info-rb-coordinate))))))))
4733 (defun table--cell-insert-char (char &optional overwrite)
4734 "Insert CHAR inside a table cell."
4735 (let ((delete-selection-p (and (boundp 'delete-selection-mode)
4736 delete-selection-mode
4737 transient-mark-mode mark-active
4738 (not buffer-read-only)))
4739 (mark-coordinate (table--transcoord-table-to-cache (table--get-coordinate (mark t)))))
4740 (table-with-cache-buffer
4741 (and delete-selection-p
4742 (>= (car mark-coordinate) 0)
4743 (<= (car mark-coordinate) table-cell-info-width)
4744 (>= (cdr mark-coordinate) 0)
4745 (<= (cdr mark-coordinate) table-cell-info-height)
4746 (save-excursion
4747 (delete-region (point) (table--goto-coordinate mark-coordinate))))
4748 (if overwrite
4749 (let ((coordinate (table--get-coordinate)))
4750 (setq table-inhibit-auto-fill-paragraph t)
4751 (if (>= (car coordinate) table-cell-info-width)
4752 (if (>= (cdr coordinate) (1- table-cell-info-height))
4753 (insert "\n" char)
4754 (forward-line 1)
4755 (insert char)
4756 (unless (eolp)
4757 (delete-char 1)))
4758 (insert char)
4759 (unless (eolp)
4760 (delete-char 1))))
4761 (if (not (eq char ?\s))
4762 (if char (insert char))
4763 (if (not (looking-at "\\s *$"))
4764 (if (and table-fixed-width-mode
4765 (> (point) 2)
4766 (save-excursion
4767 (forward-char -2)
4768 (looking-at (concat "\\("
4769 (regexp-quote (char-to-string table-word-continuation-char))
4770 "\\)\n"))))
4771 (save-excursion
4772 (replace-match " " nil nil nil 1))
4773 (insert char))
4774 (let ((coordinate (table--get-coordinate)))
4775 (if (< (car coordinate) table-cell-info-width)
4776 (move-to-column (1+ (car coordinate)) t)
4777 (insert (make-string (forward-line 1) ?\n))
4778 (unless (bolp) (insert ?\n))))
4779 (setq table-inhibit-auto-fill-paragraph t))
4780 (save-excursion
4781 (let ((o-point (point)))
4782 (if (and (bolp)
4783 (or (progn
4784 (forward-paragraph)
4785 (forward-paragraph -1)
4786 (= o-point (point)))
4787 (progn
4788 (goto-char o-point)
4789 (forward-line)
4790 (setq o-point (point))
4791 (forward-paragraph)
4792 (forward-paragraph -1)
4793 (= o-point (point)))))
4794 (insert ?\n)))))))))
4796 (defun table--finish-delayed-tasks ()
4797 "Finish all outstanding delayed tasks."
4798 (if table-update-timer
4799 (table--update-cell 'now))
4800 (if table-widen-timer
4801 (table--update-cell-widened 'now))
4802 (if table-heighten-timer
4803 (table--update-cell-heightened 'now)))
4805 (defmacro table--log (&rest body)
4806 "Debug logging macro."
4807 `(with-current-buffer (get-buffer-create "log")
4808 (goto-char (point-min))
4809 (let ((standard-output (current-buffer)))
4810 ,@body)))
4812 (defun table--measure-max-width (&optional unlimited)
4813 "Return maximum width of current buffer.
4814 Normally the current buffer is expected to be already the cache
4815 buffer. The width excludes following spaces at the end of each line.
4816 Unless UNLIMITED is non-nil minimum return value is 1."
4817 (save-excursion
4818 (let ((width 0))
4819 (goto-char (point-min))
4820 (while
4821 (progn
4822 ;; do not count the following white spaces
4823 (re-search-forward "\\s *$")
4824 (goto-char (match-beginning 0))
4825 (if (> (current-column) width)
4826 (setq width (current-column)))
4827 (forward-line)
4828 (not (eobp))))
4829 (if unlimited width
4830 (max 1 width)))))
4832 (defun table--cell-to-coord (cell)
4833 "Create a cell coordinate pair from cell location pair."
4834 (if cell
4835 (cons (table--get-coordinate (car cell))
4836 (table--get-coordinate (cdr cell)))
4837 nil))
4839 (defun table--cell-list-to-coord-list (cell-list)
4840 "Create and return a coordinate list that corresponds to CELL-LIST.
4841 CELL-LIST is a list of location pairs (lu . rb), where each pair
4842 represents a cell in the list. lu is the left upper location and rb
4843 is the right bottom location of a cell. The return value is a list of
4844 coordinate pairs (lu-coord . rb-coord), where lu-coord is the left
4845 upper coordinate and rb-coord is the right bottom coordinate of a
4846 cell."
4847 (let ((coord-list))
4848 (while cell-list
4849 (let ((cell (prog1 (car cell-list) (setq cell-list (cdr cell-list)))))
4850 (setq coord-list
4851 (cons (table--cell-to-coord cell) coord-list))))
4852 (nreverse coord-list)))
4854 (defun table--test-cell-list (&optional horizontal reverse first-only pivot)
4855 "For testing `table--vertical-cell-list' and `table--horizontal-cell-list'."
4856 (let* ((current-coordinate (table--get-coordinate))
4857 (cell-list (if horizontal
4858 (table--horizontal-cell-list reverse first-only pivot)
4859 (table--vertical-cell-list reverse first-only pivot)))
4860 (count 0))
4861 (while cell-list
4862 (let* ((cell (if first-only (prog1 cell-list (setq cell-list nil))
4863 (prog1 (car cell-list) (setq cell-list (cdr cell-list)))))
4864 (dig1-str (format "%1d" (prog1 (% count 10) (setq count (1+ count))))))
4865 (goto-char (car cell))
4866 (table-with-cache-buffer
4867 (while (re-search-forward "." nil t)
4868 (replace-match dig1-str nil nil))
4869 (setq table-inhibit-auto-fill-paragraph t))
4870 (table--finish-delayed-tasks)))
4871 (table--goto-coordinate current-coordinate)))
4873 (defun table--vertical-cell-list (&optional top-to-bottom first-only pivot internal-dir internal-list internal-px)
4874 "Return a vertical cell list from the table.
4875 The return value represents a list of cells including the current cell
4876 that align vertically. Each element of the list is a cons cell (lu
4877 . rb) where lu is the cell's left upper location and rb is the cell's
4878 right bottom location. The cell order in the list is from bottom to
4879 top of the table. If optional argument TOP-TO-BOTTOM is non-nil the
4880 order is reversed as from top to bottom of the table. If optional
4881 argument FIRST-ONLY is non-nil the return value is not a list of cells
4882 but a single cons cell that is the first cell of the list, if the list
4883 had been created. If optional argument PIVOT is a symbol `left' the
4884 vertical cell search is aligned with the left edge of the current
4885 cell, otherwise aligned with the right edge of the current cell. The
4886 arguments INTERNAL-DIR, INTERNAL-LIST and INTERNAL-PX are internal use
4887 only and must not be specified."
4888 (save-excursion
4889 (let* ((cell (table--probe-cell))
4890 (lu-coordinate (table--get-coordinate (car cell)))
4891 (rb-coordinate (table--get-coordinate (cdr cell)))
4892 (px (or internal-px (car (if (eq pivot 'left) lu-coordinate rb-coordinate))))
4893 (ty (- (cdr lu-coordinate) 2))
4894 (by (+ (cdr rb-coordinate) 2)))
4895 ;; in case of finding the first cell, get the last adding item on the list
4896 (if (and (null internal-dir) first-only) (setq top-to-bottom (null top-to-bottom)))
4897 ;; travel up and process as recursion traces back (reverse order)
4898 (and cell
4899 (or (eq internal-dir 'up) (null internal-dir))
4900 (table--goto-coordinate (cons px (if top-to-bottom by ty)) 'no-extension 'no-tab-expansion)
4901 (setq internal-list (table--vertical-cell-list top-to-bottom first-only nil 'up nil px)))
4902 ;; return the last cell or add this cell to the list
4903 (if first-only (or internal-list cell)
4904 (setq internal-list (if cell (cons cell internal-list) internal-list))
4905 ;; travel down and process as entering each recursion (forward order)
4906 (and cell
4907 (or (eq internal-dir 'down) (null internal-dir))
4908 (table--goto-coordinate (cons px (if top-to-bottom ty by)) 'no-extension 'no-tab-expansion)
4909 (setq internal-list (table--vertical-cell-list top-to-bottom nil nil 'down internal-list px)))
4910 ;; return the result
4911 internal-list))))
4913 (defun table--horizontal-cell-list (&optional left-to-right first-only pivot internal-dir internal-list internal-py)
4914 "Return a horizontal cell list from the table.
4915 The return value represents a list of cells including the current cell
4916 that align horizontally. Each element of the list is a cons cells (lu
4917 . rb) where lu is the cell's left upper location and rb is the cell's
4918 right bottom location. The cell order in the list is from right to
4919 left of the table. If optional argument LEFT-TO-RIGHT is non-nil the
4920 order is reversed as from left to right of the table. If optional
4921 argument FIRST-ONLY is non-nil the return value is not a list of cells
4922 but a single cons cell that is the first cell of the list, if the
4923 list had been created. If optional argument PIVOT is a symbol `top'
4924 the horizontal cell search is aligned with the top edge of the current
4925 cell, otherwise aligned with the bottom edge of the current cell. The
4926 arguments INTERNAL-DIR, INTERNAL-LIST and INTERNAL-PY are internal use
4927 only and must not be specified."
4928 (save-excursion
4929 (let* ((cell (table--probe-cell))
4930 (lu-coordinate (table--get-coordinate (car cell)))
4931 (rb-coordinate (table--get-coordinate (cdr cell)))
4932 (py (or internal-py (if (eq pivot 'top) (cdr lu-coordinate) (1+ (cdr rb-coordinate)))))
4933 (lx (1- (car lu-coordinate)))
4934 (rx (1+ (car rb-coordinate))))
4935 ;; in case of finding the first cell, get the last adding item on the list
4936 (if (and (null internal-dir) first-only) (setq left-to-right (null left-to-right)))
4937 ;; travel left and process as recursion traces back (reverse order)
4938 (and cell
4939 (or (eq internal-dir 'left) (null internal-dir))
4940 (table--goto-coordinate (cons (if left-to-right rx lx) py) 'no-extension 'no-tab-expansion)
4941 (setq internal-list (table--horizontal-cell-list left-to-right first-only nil 'left nil py)))
4942 ;; return the last cell or add this cell to the list
4943 (if first-only (or internal-list cell)
4944 (setq internal-list (if cell (cons cell internal-list) internal-list))
4945 ;; travel right and process as entering each recursion (forward order)
4946 (and cell
4947 (or (eq internal-dir 'right) (null internal-dir))
4948 (table--goto-coordinate (cons (if left-to-right lx rx) py) 'no-extension 'no-tab-expansion)
4949 (setq internal-list (table--horizontal-cell-list left-to-right nil nil 'right internal-list py)))
4950 ;; return the result
4951 internal-list))))
4953 (defun table--point-in-cell-p (&optional location)
4954 "Return t when point is in a valid table cell in the current buffer.
4955 When optional LOCATION is provided the test is performed at that location."
4956 (and (table--at-cell-p (or location (point)))
4957 (if location
4958 (save-excursion
4959 (goto-char location)
4960 (table--probe-cell))
4961 (table--probe-cell))))
4963 (defun table--region-in-cell-p (beg end)
4964 "Return t when location BEG and END are in a valid table cell in the current buffer."
4965 (and (table--at-cell-p (min beg end))
4966 (save-excursion
4967 (let ((cell-beg (progn (goto-char beg) (table--probe-cell))))
4968 (and cell-beg
4969 (equal cell-beg (progn (goto-char end) (table--probe-cell))))))))
4971 (defun table--at-cell-p (position &optional object at-column)
4972 "Returns non-nil if POSITION has table-cell property in OBJECT.
4973 OBJECT is optional and defaults to the current buffer.
4974 If POSITION is at the end of OBJECT, the value is nil."
4975 (if (and at-column (stringp object))
4976 (setq position (table--str-index-at-column object position)))
4977 (get-text-property position 'table-cell object))
4979 (defun table--probe-cell-left-up ()
4980 "Probe left up corner pattern of a cell.
4981 If it finds a valid corner returns a position otherwise returns nil.
4982 The position is the location before the first cell character.
4983 Focus only on the corner pattern. Further cell validity check is required."
4984 (save-excursion
4985 (let ((vertical-str (regexp-quote (char-to-string table-cell-vertical-char)))
4986 (intersection-str (regexp-quote (char-to-string table-cell-intersection-char)))
4987 (v-border (format "[%c%c]" table-cell-vertical-char table-cell-intersection-char))
4988 (h-border (format "[%s%c]" table-cell-horizontal-chars table-cell-intersection-char))
4989 (limit (line-beginning-position)))
4990 (catch 'end
4991 (while t
4992 (catch 'retry-horizontal
4993 (if (not (search-backward-regexp v-border limit t))
4994 (throw 'end nil))
4995 (save-excursion
4996 (let ((column (current-column)))
4997 (while t
4998 (catch 'retry-vertical
4999 (if (zerop (forward-line -1)) nil (throw 'end nil))
5000 (move-to-column column)
5001 (while (and (looking-at vertical-str)
5002 (= column (current-column)))
5003 (if (zerop (forward-line -1)) nil (throw 'end nil))
5004 (move-to-column column))
5005 (cond
5006 ((/= column (current-column))
5007 (throw 'end nil))
5008 ((looking-at (concat intersection-str h-border))
5009 (forward-line 1)
5010 (move-to-column column)
5011 (forward-char 1)
5012 (throw 'end (point)))
5013 ((looking-at intersection-str)
5014 (throw 'retry-vertical nil))
5015 (t (throw 'retry-horizontal nil)))))))))))))
5017 (defun table--probe-cell-right-bottom ()
5018 "Probe right bottom corner pattern of a cell.
5019 If it finds a valid corner returns a position otherwise returns nil.
5020 The position is the location after the last cell character.
5021 Focus only on the corner pattern. Further cell validity check is required."
5022 (save-excursion
5023 (let ((vertical-str (regexp-quote (char-to-string table-cell-vertical-char)))
5024 (intersection-str (regexp-quote (char-to-string table-cell-intersection-char)))
5025 (v-border (format "[%c%c]" table-cell-vertical-char table-cell-intersection-char))
5026 (h-border (format "[%s%c]" table-cell-horizontal-chars table-cell-intersection-char))
5027 (limit (line-end-position)))
5028 (catch 'end
5029 (while t
5030 (catch 'retry-horizontal
5031 (if (not (search-forward-regexp v-border limit t))
5032 (throw 'end nil))
5033 (save-excursion
5034 (forward-char -1)
5035 (let ((column (current-column)))
5036 (while t
5037 (catch 'retry-vertical
5038 (while (and (looking-at vertical-str)
5039 (= column (current-column)))
5040 (if (and (zerop (forward-line 1)) (zerop (current-column))) nil (throw 'end nil))
5041 (move-to-column column))
5042 (cond
5043 ((/= column (current-column))
5044 (throw 'end nil))
5045 ((save-excursion (forward-char -1) (looking-at (concat h-border intersection-str)))
5046 (save-excursion
5047 (and (zerop (forward-line -1))
5048 (move-to-column column)
5049 (looking-at v-border)
5050 (throw 'end (point))))
5051 (forward-char 1)
5052 (throw 'retry-horizontal nil))
5053 ((looking-at intersection-str)
5054 (if (and (zerop (forward-line 1)) (zerop (current-column))) nil (throw 'end nil))
5055 (move-to-column column)
5056 (throw 'retry-vertical nil))
5057 (t (throw 'retry-horizontal nil)))))))))))))
5059 (defun table--editable-cell-p (&optional _abort-on-error)
5060 (and (not buffer-read-only)
5061 (get-text-property (point) 'table-cell)))
5063 (defun table--probe-cell (&optional abort-on-error)
5064 "Probes a table cell around the point.
5065 Searches for the left upper corner and the right bottom corner of a table
5066 cell which contains the current point location.
5068 The result is a cons cell (left-upper . right-bottom) where
5069 the left-upper is the position before the cell's left upper corner character,
5070 the right-bottom is the position after the cell's right bottom corner character.
5072 When it fails to find either one of the cell corners it returns nil or
5073 signals error if the optional ABORT-ON-ERROR is non-nil."
5074 (let (lu rb
5075 (border (format "^[%s%c%c]+$"
5076 table-cell-horizontal-chars
5077 table-cell-vertical-char
5078 table-cell-intersection-char)))
5079 (if (and (condition-case nil
5080 (progn
5081 (and (setq lu (table--probe-cell-left-up))
5082 (setq rb (table--probe-cell-right-bottom))))
5083 (error nil))
5084 (< lu rb)
5085 (let ((lu-coordinate (table--get-coordinate lu))
5086 (rb-coordinate (table--get-coordinate rb)))
5087 ;; test for valid upper and lower borders
5088 (and (string-match
5089 border
5090 (buffer-substring
5091 (save-excursion
5092 (table--goto-coordinate
5093 (cons (1- (car lu-coordinate))
5094 (1- (cdr lu-coordinate)))))
5095 (save-excursion
5096 (table--goto-coordinate
5097 (cons (1+ (car rb-coordinate))
5098 (1- (cdr lu-coordinate)))))))
5099 (string-match
5100 border
5101 (buffer-substring
5102 (save-excursion
5103 (table--goto-coordinate
5104 (cons (1- (car lu-coordinate))
5105 (1+ (cdr rb-coordinate)))))
5106 (save-excursion
5107 (table--goto-coordinate
5108 (cons (1+ (car rb-coordinate))
5109 (1+ (cdr rb-coordinate))))))))))
5110 (cons lu rb)
5111 (if abort-on-error
5112 (error "Table cell not found")
5113 nil))))
5115 (defun table--insert-rectangle (rectangle)
5116 "Insert text of RECTANGLE with upper left corner at point.
5117 Same as insert-rectangle except that mark operation is eliminated."
5118 (let ((lines rectangle)
5119 (insertcolumn (current-column))
5120 (first t))
5121 (while lines
5122 (or first
5123 (progn
5124 (forward-line 1)
5125 (or (bolp) (insert ?\n))
5126 (move-to-column insertcolumn t)))
5127 (setq first nil)
5128 (insert (car lines))
5129 (setq lines (cdr lines)))))
5131 (defun table--put-cell-property (cell)
5132 "Put standard text properties to the CELL.
5133 The CELL is a cons cell (left-upper . right-bottom) where the
5134 left-upper is the position before the cell's left upper corner
5135 character, the right-bottom is the position after the cell's right
5136 bottom corner character."
5137 (let ((lu (table--get-coordinate (car cell)))
5138 (rb (table--get-coordinate (cdr cell))))
5139 (save-excursion
5140 (while (<= (cdr lu) (cdr rb))
5141 (let ((beg (table--goto-coordinate lu 'no-extension))
5142 (end (table--goto-coordinate (cons (car rb) (cdr lu)))))
5143 (table--put-cell-line-property beg end))
5144 (setcdr lu (1+ (cdr lu))))
5145 (table--put-cell-justify-property cell table-cell-info-justify)
5146 (table--put-cell-valign-property cell table-cell-info-valign))))
5148 (defun table--put-cell-line-property (beg end &optional object)
5149 "Put standard text properties to a line of a cell.
5150 BEG is the beginning of the line that is the location between left
5151 cell border character and the first content character. END is the end
5152 of the line that is the location between the last content character
5153 and the right cell border character."
5154 (table--put-cell-content-property beg end object)
5155 (table--put-cell-keymap-property end (1+ end) object)
5156 (table--put-cell-indicator-property end (1+ end) object)
5157 (table--put-cell-rear-nonsticky end (1+ end) object))
5159 (defun table--put-cell-content-property (beg end &optional object)
5160 "Put cell content text properties."
5161 (table--put-cell-keymap-property beg end object)
5162 (table--put-cell-indicator-property beg end object)
5163 (table--put-cell-face-property beg end object)
5164 (table--put-cell-point-entered/left-property beg end object))
5166 (defun table--put-cell-indicator-property (beg end &optional object)
5167 "Put cell property which indicates that the location is within a table cell."
5168 (put-text-property beg end 'table-cell t object)
5169 (put-text-property beg end 'yank-handler table-yank-handler object))
5171 (defun table--put-cell-face-property (beg end &optional object)
5172 "Put cell face property."
5173 (put-text-property beg end 'face 'table-cell object))
5175 (defun table--put-cell-keymap-property (beg end &optional object)
5176 "Put cell keymap property."
5177 (put-text-property beg end 'keymap 'table-cell-map object))
5179 (defun table--put-cell-rear-nonsticky (beg end &optional object)
5180 "Put rear-nonsticky property."
5181 (put-text-property beg end 'rear-nonsticky t object))
5183 (defun table--put-cell-point-entered/left-property (beg end &optional object)
5184 "Put point-entered/left property."
5185 (put-text-property beg end 'point-entered 'table--point-entered-cell-function object)
5186 (put-text-property beg end 'point-left 'table--point-left-cell-function object))
5188 (defun table--remove-cell-properties (beg end &optional object)
5189 "Remove all cell properties.
5190 If OBJECT is non-nil cell properties are removed from the OBJECT
5191 instead of the current buffer and returns the OBJECT."
5192 (while (< beg end)
5193 (let ((next (next-single-property-change beg 'table-cell object end)))
5194 (if (get-text-property beg 'table-cell object)
5195 (remove-text-properties beg next
5196 (list
5197 'table-cell nil
5198 'table-justify nil
5199 'table-valign nil
5200 'face nil
5201 'rear-nonsticky nil
5202 'point-entered nil
5203 'point-left nil
5204 'keymap nil)
5205 object))
5206 (setq beg next)))
5207 object)
5209 (defun table--update-cell-face ()
5210 "Update cell face according to the current mode."
5211 (if (featurep 'xemacs)
5212 (set-face-property 'table-cell 'underline table-fixed-width-mode)
5213 (set-face-inverse-video-p 'table-cell table-fixed-width-mode)))
5215 (table--update-cell-face)
5217 (defun table--get-property (cell property)
5218 "Get CELL's PROPERTY."
5219 (or (get-text-property (car cell) property)
5220 (get-text-property (1- (cdr cell)) property)))
5222 (defun table--get-cell-justify-property (cell)
5223 "Get cell's justify property."
5224 (table--get-property cell 'table-justify))
5226 (defun table--get-cell-valign-property (cell)
5227 "Get cell's vertical alignment property."
5228 (table--get-property cell 'table-valign))
5230 (defun table--put-property (cell property value)
5231 "Put CELL's PROPERTY the VALUE."
5232 (let ((beg (car cell))
5233 (end (cdr cell)))
5234 (put-text-property beg (1+ beg) property value)
5235 (put-text-property (1- end) end property value)))
5237 (defun table--put-cell-justify-property (cell justify)
5238 "Put cell's justify property."
5239 (table--put-property cell 'table-justify justify))
5241 (defun table--put-cell-valign-property (cell valign)
5242 "Put cell's vertical alignment property."
5243 (table--put-property cell 'table-valign valign))
5245 (defun table--point-entered-cell-function (&optional _old-point _new-point)
5246 "Point has entered a cell.
5247 Refresh the menu bar."
5248 ;; Avoid calling point-motion-hooks recursively.
5249 (let ((inhibit-point-motion-hooks t))
5250 (unless table-cell-entered-state
5251 (setq table-cell-entered-state t)
5252 (setq table-mode-indicator t)
5253 (force-mode-line-update)
5254 (table--warn-incompatibility)
5255 (run-hooks 'table-point-entered-cell-hook))))
5257 (defun table--point-left-cell-function (&optional _old-point _new-point)
5258 "Point has left a cell.
5259 Refresh the menu bar."
5260 ;; Avoid calling point-motion-hooks recursively.
5261 (let ((inhibit-point-motion-hooks t))
5262 (when table-cell-entered-state
5263 (setq table-cell-entered-state nil)
5264 (setq table-mode-indicator nil)
5265 (force-mode-line-update)
5266 (run-hooks 'table-point-left-cell-hook))))
5268 (defun table--warn-incompatibility ()
5269 "If called from interactive operation warn the know incompatibilities.
5270 This feature is disabled when `table-disable-incompatibility-warning'
5271 is non-nil. The warning is done only once per session for each item."
5272 (unless (and table-disable-incompatibility-warning
5273 (not (called-interactively-p 'interactive)))
5274 (cond ((and (featurep 'xemacs)
5275 (not (get 'table-disable-incompatibility-warning 'xemacs)))
5276 (put 'table-disable-incompatibility-warning 'xemacs t)
5277 (display-warning 'table
5279 *** Warning ***
5281 Table package mostly works fine under XEmacs, however, due to the
5282 peculiar implementation of text property under XEmacs, cell splitting
5283 and any undo operation of table exhibit some known strange problems,
5284 such that a border characters dissolve into adjacent cells. Please be
5285 aware of this.
5288 :warning))
5289 ((and (boundp 'flyspell-mode)
5290 flyspell-mode
5291 (not (get 'table-disable-incompatibility-warning 'flyspell)))
5292 (put 'table-disable-incompatibility-warning 'flyspell t)
5293 (display-warning 'table
5295 *** Warning ***
5297 Flyspell minor mode is known to be incompatible with this table
5298 package. The flyspell version 1.5d at URL `http://kaolin.unice.fr/~serrano'
5299 works better than the previous versions however not fully compatible.
5302 :warning))
5305 (defun table--cell-blank-str (&optional n)
5306 "Return blank table cell string of length N."
5307 (let ((str (make-string (or n 1) ?\s)))
5308 (table--put-cell-content-property 0 (length str) str)
5309 str))
5311 (defun table--remove-eol-spaces (beg end &optional bol force)
5312 "Remove spaces at the end of each line in the BEG END region of the current buffer.
5313 When optional BOL is non-nil spaces at the beginning of line are
5314 removed. When optional FORCE is non-nil removal operation is enforced
5315 even when point is within the removal area."
5316 (if (> beg end)
5317 (let ((tmp beg))
5318 (setq beg end)
5319 (setq end tmp)))
5320 (let ((saved-point (point-marker))
5321 (end-marker (copy-marker end)))
5322 (save-excursion
5323 (goto-char beg)
5324 (while (if bol (re-search-forward "^\\( +\\)" end-marker t)
5325 (re-search-forward "\\( +\\)$" end-marker t))
5326 ;; avoid removal that causes the saved point to lose its location.
5327 (if (and (null bol)
5328 (<= (match-beginning 1) saved-point)
5329 (<= saved-point (match-end 1))
5330 (not force))
5331 (delete-region saved-point (match-end 1))
5332 (delete-region (match-beginning 1) (match-end 1)))))
5333 (set-marker saved-point nil)
5334 (set-marker end-marker nil)))
5336 (defun table--fill-region (beg end &optional col justify)
5337 "Fill paragraphs in table cell cache.
5338 Current buffer must already be set to the cache buffer."
5339 (let ((fill-column (or col table-cell-info-width))
5340 (fill-prefix nil)
5341 (enable-kinsoku nil)
5342 (adaptive-fill-mode nil)
5343 (marker-beg (copy-marker beg))
5344 (marker-end (copy-marker end))
5345 (marker-point (point-marker)))
5346 (setq justify (or justify table-cell-info-justify))
5347 (and justify
5348 (not (eq justify 'left))
5349 (not (featurep 'xemacs))
5350 (set-marker-insertion-type marker-point t))
5351 (table--remove-eol-spaces (point-min) (point-max))
5352 (if table-fixed-width-mode
5353 (table--fill-region-strictly marker-beg marker-end)
5354 (let ((paragraph-start table-paragraph-start))
5355 (fill-region marker-beg marker-end justify nil t)))
5356 (goto-char marker-point)
5357 (set-marker marker-beg nil)
5358 (set-marker marker-end nil)
5359 (set-marker marker-point nil)))
5361 (defun table--fill-region-strictly (beg end)
5362 "Fill region strictly so that no line exceeds fill-column.
5363 When a word exceeds fill-column the word is chopped into pieces. The
5364 chopped location is indicated with table-word-continuation-char."
5365 (or (and (markerp beg) (markerp end))
5366 (error "markerp"))
5367 (if (< fill-column 2)
5368 (setq fill-column 2))
5369 ;; first remove all continuation characters.
5370 (goto-char beg)
5371 (while (re-search-forward (concat
5372 (format "[^%c ]\\(" table-word-continuation-char)
5373 (regexp-quote (char-to-string table-word-continuation-char))
5374 "\\s +\\)")
5375 end t)
5376 (delete-region (match-beginning 1) (match-end 1)))
5377 ;; then fill as normal
5378 (let ((paragraph-start table-paragraph-start))
5379 (fill-region beg end nil nil t))
5380 ;; now fix up
5381 (goto-char beg)
5382 (while (let ((col (move-to-column fill-column t)))
5383 (cond
5384 ((and (<= col fill-column)
5385 (looking-at " *$"))
5386 (delete-region (match-beginning 0) (match-end 0))
5387 (and (zerop (forward-line 1))
5388 (< (point) end)))
5389 (t (forward-char -1)
5390 (insert-before-markers (if (equal (char-before) ?\s) ?\s table-word-continuation-char)
5391 "\n")
5392 t)))))
5394 (defun table--goto-coordinate (coordinate &optional no-extension no-tab-expansion)
5395 "Move point to the given COORDINATE and return the location.
5396 When optional NO-EXTENSION is non-nil and the specified coordinate is
5397 not reachable returns nil otherwise the blanks are added if necessary
5398 to achieve the goal coordinate and returns the goal point. It
5399 intentionally does not preserve the original point in case it fails
5400 achieving the goal. When optional NO-TAB-EXPANSION is non-nil and the
5401 goad happens to be in a tab character the tab is not expanded but the
5402 goal ends at the beginning of tab."
5403 (if (or (null coordinate)
5404 (< (car coordinate) 0)
5405 (< (cdr coordinate) 0)) nil
5406 (goto-char (point-min))
5407 (let ((x (car coordinate))
5408 (more-lines (forward-line (cdr coordinate))))
5409 (catch 'exit
5410 (if (zerop (current-column)) nil
5411 (if no-extension
5412 (progn
5413 (move-to-column x)
5414 (throw 'exit nil))
5415 (setq more-lines (1+ more-lines))))
5416 (if (zerop more-lines) nil
5417 (newline more-lines))
5418 (if no-extension
5419 (if (/= (move-to-column x) x)
5420 (if (> (move-to-column x) x)
5421 (if no-tab-expansion
5422 (progn
5423 (while (> (move-to-column x) x)
5424 (setq x (1- x)))
5425 (point))
5426 (throw 'exit (move-to-column x t)))
5427 (throw 'exit nil)))
5428 (move-to-column x t))
5429 (point)))))
5431 (defun table--copy-coordinate (coord)
5432 "Copy coordinate in a new cons cell."
5433 (cons (car coord) (cdr coord)))
5435 (defun table--get-coordinate (&optional where)
5436 "Return the coordinate of point in current buffer.
5437 When optional WHERE is given it returns the coordinate of that
5438 location instead of point in the current buffer. It does not move the
5439 point"
5440 (save-excursion
5441 (if where (goto-char where))
5442 (cons (current-column)
5443 (table--current-line))))
5445 (defun table--current-line (&optional location)
5446 "Return zero based line count of current line or if non-nil LOCATION line."
5447 (save-excursion
5448 (if location (goto-char location))
5449 (beginning-of-line)
5450 (count-lines (point-min) (point))))
5452 (defun table--transcoord-table-to-cache (&optional coordinate)
5453 "Transpose COORDINATE from table coordinate system to cache coordinate system.
5454 When COORDINATE is omitted or nil the point in current buffer is assumed in place."
5455 (table--offset-coordinate
5456 (or coordinate (table--get-coordinate))
5457 table-cell-info-lu-coordinate
5458 'negative))
5460 (defun table--transcoord-cache-to-table (&optional coordinate)
5461 "Transpose COORDINATE from cache coordinate system to table coordinate system.
5462 When COORDINATE is omitted or nil the point in current buffer is assumed in place."
5463 (table--offset-coordinate
5464 (or coordinate (table--get-coordinate))
5465 table-cell-info-lu-coordinate))
5467 (defun table--offset-coordinate (coordinate offset &optional negative)
5468 "Return the offset COORDINATE by OFFSET.
5469 When optional NEGATIVE is non-nil offsetting direction is negative."
5470 (cons (if negative (- (car coordinate) (car offset))
5471 (+ (car coordinate) (car offset)))
5472 (if negative (- (cdr coordinate) (cdr offset))
5473 (+ (cdr coordinate) (cdr offset)))))
5475 (defun table--char-in-str-at-column (str column)
5476 "Return the character in STR at COLUMN location.
5477 When COLUMN is out of range it returns null character."
5478 (let ((idx (table--str-index-at-column str column)))
5479 (if idx (aref str idx)
5480 ?\0)))
5482 (defun table--str-index-at-column (str column)
5483 "Return the character index in STR that corresponds to COLUMN location.
5484 It returns COLUMN unless STR contains some wide characters."
5485 (let ((col 0)
5486 (idx 0)
5487 (len (length str)))
5488 (while (and (< col column) (< idx len))
5489 (setq col (+ col (char-width (aref str idx))))
5490 (setq idx (1+ idx)))
5491 (if (< idx len)
5493 nil)))
5495 (defun table--set-timer (seconds func args)
5496 "Generic wrapper for setting up a timer."
5497 (if (featurep 'xemacs)
5498 ;; the picky xemacs refuses to accept zero
5499 (add-timeout (if (zerop seconds) 0.01 seconds) func args nil)
5500 ;;(run-at-time seconds nil func args)))
5501 ;; somehow run-at-time causes strange problem under Emacs 20.7
5502 ;; this problem does not show up under Emacs 21.0.90
5503 (run-with-idle-timer seconds nil func args)))
5505 (defun table--cancel-timer (timer)
5506 "Generic wrapper for canceling a timer."
5507 (if (featurep 'xemacs)
5508 (disable-timeout timer)
5509 (cancel-timer timer)))
5511 (defun table--get-last-command ()
5512 "Generic wrapper for getting the real last command."
5513 (if (boundp 'real-last-command)
5514 real-last-command
5515 last-command))
5517 (run-hooks 'table-load-hook)
5519 (provide 'table)
5521 ;;; table.el ends here