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