comparison lisp/ses.el @ 58409:924fa48ab4bf

Add coding cookie. Fix up docstrings, follow new commenting conventions. (ses-header-line-menu): Fix missing variable rename for header-row. (ses-cell-size): Remove. (ses-make-cell): New function. (ses-cell, ses-insert-row, ses-insert-column): Use it. (ses-calculate-cell): Remove unused var `symbol'. (ses-narrowed-p): New function. (ses-goto-data, undo-more, ses-reconstruct-all): Use it. (ses-initial-file-trailer): Change ;;; to ;; for local vars. (ses-load, ses-reconstruct-all): Adjust string search accordingly. (ses-setup): Use restore-buffer-modified-p. (ses-cleanup): Remove unused var `end'. (ses-header-string-left-offset): Remove. (ses-create-header-string): Adjust to new behavior of `align-to'. Truncate excessively large fields to preserve alignment. (ses-reconstruct-all): Remove unused var `refs'. (ses-read-cell-printer): Remove unused var `prompt'. (ses-delete-row): Remove unused var `pos'. (ses-delete-column): Remove unused var `new'.

58408:6b5846d74ff0

;;; ses.el -- Simple Emacs Spreadsheet

;; Copyright (C) 2002,03,04  Free Software Foundation, Inc.

;; Author: Jonathan Yavner <[e-mail]>
;; Maintainer: Jonathan Yavner <[e-mail]>

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; To-do list:
;; * Use $ or … for truncated fields
;; * Add command to make a range of columns be temporarily invisible.
;; * Allow paste of one cell to a range of cells -- copy formula to each.
;; * Do something about control characters & octal codes in cell print
;;   areas.  Use string-width?

;; * Faces (colors & styles) in print cells.
;; * Move a column by dragging its letter in the header line.
;; * Left-margin column for row number.
;; * Move a row by dragging its number in the left-margin.

(require 'unsafep)


;;;----------------------------------------------------------------------------
;;;; User-customizable variables
;;;----------------------------------------------------------------------------

(defgroup ses nil
  "Simple Emacs Spreadsheet"
  :group  'applications
  :prefix "ses-"

  :type  '(choice string
		  (list :tag "Parenthesized string" string)
		  function))

(defcustom ses-after-entry-functions '(forward-char)
  "Things to do after entering a value into a cell.  An abnormal hook that
usually runs a cursor-movement function.  Each function is called with ARG=1."
  :group 'ses
  :type 'hook
  :options '(forward-char backward-char next-line previous-line))

(defcustom ses-mode-hook nil
  "Hook functions to be run upon entering SES mode."
  :group 'ses
  :type 'hook)


;;;----------------------------------------------------------------------------
;;;; Global variables and constants
;;;----------------------------------------------------------------------------

(defvar ses-read-cell-history nil
  "List of formulas that have been typed in.")

(defvar ses-read-printer-history nil

(easy-menu-define ses-header-line-menu nil
  "Context menu when mouse-3 is used on the header-line in an SES buffer."
  '("SES header row"
    ["Set current row" ses-set-header-row t]
    ["Unset row" ses-unset-header-row (> header-row 0)]))

(defconst ses-mode-map
  (let ((keys `("\C-c\M-\C-l" ses-reconstruct-all
		"\C-c\C-l"    ses-recalculate-all
		"\C-c\C-n"    ses-renarrow-buffer

    (define-key map "T" (cons " tab-formulas" 'ses-export-tsf))
    (define-key map "t" (cons " tab-values" 'ses-export-tsv))
    map))

(defconst ses-print-data-boundary "\n\014\n"
  "Marker string denoting the boundary between print area and data area")

(defconst ses-initial-global-parameters
  "\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n"
  "Initial contents for the three-element list at the bottom of the data area")

(defconst ses-initial-file-trailer
  ";;; Local Variables:\n;;; mode: ses\n;;; End:\n"
  "Initial contents for the file-trailer area at the bottom of the file.")

(defconst ses-initial-file-contents
  (concat "       \n" ;One blank cell in print area
	  ses-print-data-boundary

	  "(ses-header-row 0)\n"
	  ses-initial-global-parameters
	  ses-initial-file-trailer)
  "The initial contents of an empty spreadsheet.")

(defconst ses-cell-size 4
  "A cell consists of a SYMBOL, a FORMULA, a PRINTER-function, and a list of
REFERENCES.")

(defconst ses-paramlines-plist
  '(ses--col-widths  2 ses--col-printers  3 ses--default-printer  4
    ses--header-row  5 ses--file-format   8 ses--numrows          9
    ses--numcols    10)
  "Offsets from last cell line to various parameter lines in the data area

  (dolist (x ses-localvars)
    (make-local-variable x)
    (set x nil)))


;;;
;;;  "Side-effect variables".  They are set in one function, altered in
;;;  another as a side effect, then read back by the first, as a way of
;;;  passing back more than one value.  These declarations are just to make
;;;  the compiler happy, and to conform to standard Emacs-Lisp practice (I
;;;  think the make-local-variable trick above is cleaner).
;;;

(defvar ses-relocate-return nil
  "Set by `ses-relocate-formula' and `ses-relocate-range', read by
`ses-relocate-all'.  Set to 'delete if a cell-reference was deleted from a
formula--so the formula needs recalculation.  Set to 'range if the size of a

(defvar ses-start-time nil
  "Time when current operation started.  Used by `ses-time-check' to decide
when to emit a progress message.")


;;;----------------------------------------------------------------------------
;;;; Macros
;;;----------------------------------------------------------------------------

(defmacro ses-get-cell (row col)
  "Return the cell structure that stores information about cell (ROW,COL)."
  `(aref (aref ses--cells ,row) ,col))

(defmacro ses-cell-symbol (row &optional col)
  "From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value.  (0,0) => A1."
  `(aref ,(if col `(ses-get-cell ,row ,col) row) 0))

	(stringp printer)
	(eq safe-functions t)
	(setq printer `(ses-safe-printer ,printer)))
    (aset (aref ses--cells (car rowcol))
	  (cdr rowcol)
	  (vector sym formula printer references)))
  (set sym value)
  sym)

(defmacro ses-column-widths (widths)
  "Load the vector of column widths from the spreadsheet file.  This is a

(defmacro noreturn (form)
  "For code-coverage testing, indicate that FORM will always signal an error."
  form)


;;;----------------------------------------------------------------------------
;;;; Utility functions
;;;----------------------------------------------------------------------------

(defun ses-vector-insert (array idx new)
  "Create a new vector which is one larger than ARRAY and has NEW inserted
before element IDX."
  (let* ((len    (length array))

	      xcol (+ col mincol)
	      sym  (ses-create-cell-symbol xrow xcol))
	(put sym 'ses-cell (cons xrow xcol))
	(make-local-variable sym)))))

;;;We do not delete the ses-cell properties for the cell-variables, in case a
;;;formula that refers to this cell is in the kill-ring and is later pasted
;;;back in.
(defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol)
  "Destroy buffer-local variables for cells.  This is undoable."
  (let (sym)
    (dotimes (row (1+ (- maxrow minrow)))
      (dotimes (col (1+ (- maxcol mincol)))

    (message format (eval arg))
    (setq ses-start-time (float-time)))
  nil)


;;;----------------------------------------------------------------------------
;;;; The cells
;;;----------------------------------------------------------------------------

(defun ses-set-cell (row col field val)
  "Install VAL as the contents for field FIELD (named by a quoted symbol) of
cell (ROW,COL).  This is undoable.  The cell's data will be updated through
`post-command-hook'."

  Any cells that depend on this cell are queued for update after the end of
processing for the current keystroke, unless the new value is the same as
the old and FORCE is nil."
  (let ((cell (ses-get-cell row col))
	formula-error printer-error)
    (let ((symbol  (ses-cell-symbol  cell))
	  (oldval  (ses-cell-value   cell))
	  (formula (ses-cell-formula cell))
	  newval)
      (if (eq (car-safe formula) 'ses-safe-formula)
	  (ses-set-cell row col 'formula (ses-safe-formula (cadr formula))))
      (condition-case sig

    ;;Can't use save-excursion here: if the cell under point is
    ;;updated, save-excusion's marker will move past the cell.
    (goto-char pos)))


;;;----------------------------------------------------------------------------
;;;; The print area
;;;----------------------------------------------------------------------------

(defun ses-in-print-area ()
  "Returns t if point is in print area of spreadsheet."
  (eq (get-text-property (point) 'keymap) 'ses-mode-print-map))

;;;We turn off point-motion-hooks and explicitly position the cursor, in case
;;;the intangible properties have gotten screwed up (e.g., when
;;;ses-goto-print is called during a recursive ses-print-cell).
(defun ses-goto-print (row col)
  "Move point to print area for cell (ROW,COL)."
  (let ((inhibit-point-motion-hooks t))
    (goto-char (point-min))
    (forward-line row)

	(error "Can't use a range")))
   ((memq 'needrange args)
    (error "Need a range"))))

(defun ses-print-cell (row col)
  "Format and print the value of cell (ROW,COL) to the print area, using the
cell's printer function.  If the cell's new print form is too wide, it will
spill over into the following cell, but will not run off the end of the row
or overwrite the next non-nil field.  Result is nil for normal operation, or
the error signal if the printer function failed and the cell was formatted
with \"%s\".  If the cell's value is *skip*, nothing is printed because the
preceding cell has spilled over."
  (catch 'ses-print-cell
    (let* ((cell    (ses-get-cell row col))
	   (value   (ses-cell-value cell))

    (backward-char 1)
    (let ((rowcol (ses-sym-rowcol (get-text-property (point) 'intangible))))
      (ses-print-cell (car rowcol) (cdr rowcol)))))


;;;----------------------------------------------------------------------------
;;;; The data area
;;;----------------------------------------------------------------------------

(defun ses-goto-data (def &optional col)
  "Move point to data area for (DEF,COL).  If DEF is a row
number, COL is the column number for a data cell -- otherwise DEF
is one of the symbols ses--col-widths, ses--col-printers,
ses--default-printer, ses--numrows, or ses--numcols."
  (if (< (point-max) (buffer-size))
      (setq ses--deferred-narrow t))
  (widen)
  (let ((inhibit-point-motion-hooks t)) ;In case intangible attrs are wrong
    (goto-char (point-min))
    (if col

    (setq def (plist-get ses-paramlines-plist def))
    (or def (signal 'args-out-of-range nil))
    (forward-line (+ (* ses--numrows (+ ses--numcols 2)) def)))))

(defun ses-set-parameter (def value &optional elem)
  "Sets parameter DEF to VALUE (with undo) and writes the value to the data
area.  See `ses-goto-data' for meaning of DEF.  Newlines in the data
are escaped.  If ELEM is specified, it is the array subscript within DEF to
be set to VALUE."
  (save-excursion
    ;;We call ses-goto-data early, using the old values of numrows and
    ;;numcols in case one of them is being changed.
    (ses-goto-data def)
    (if elem

			  def)))
      (delete-region (point) (line-end-position))
      (insert (format fmt (symbol-value def))))))

(defun ses-write-cells ()
  "`ses--deferred-write' is a list of (ROW,COL) for cells to be written from
buffer-local variables to data area.  Newlines in the data are escaped."
  (let* ((inhibit-read-only t)
	 (print-escape-newlines t)
	 rowcol row col cell sym formula printer text)
    (setq ses-start-time (float-time))
    (with-temp-message " "

	  (delete-region (point) (line-end-position))
	  (insert text)))
      (message " "))))


;;;----------------------------------------------------------------------------
;;;; Formula relocation
;;;----------------------------------------------------------------------------

(defun ses-formula-references (formula &optional result-so-far)
  "Produce a list of symbols for cells that this formula's value
refers to.  For recursive calls, RESULT-SO-FAR is the list being constructed,
or t to get a wrong-type-argument error when the first reference is found."

		reform (cdr reform))
	  (ses-cell-set-formula row col (ses-cell-formula row col))))
      (message nil))))


;;;----------------------------------------------------------------------------
;;;; Undo control
;;;----------------------------------------------------------------------------

(defadvice undo-more (around ses-undo-more activate preactivate)
  "Define a meaning for conses in buffer-undo-list whose car is a symbol
other than t or nil.  To undo these, apply the car--a function--to the
cdr--its arglist."

	     (apply (car ses-x) (cdr ses-x)))))
    (if (not (eq major-mode 'ses-mode))
	ad-do-it
      ;;Here is some extra code for SES mode.
      (setq ses--deferred-narrow
	    (or ses--deferred-narrow (< (point-max) (buffer-size))))
      (widen)
      (condition-case x
	  ad-do-it
	(error
	 ;;Restore narrow if appropriate

    (push `(ses-aset-with-undo ,array ,idx ,(aref array idx)) buffer-undo-list)
    (aset array idx newval)
    t))


;;;----------------------------------------------------------------------------
;;;; Startup for major mode
;;;----------------------------------------------------------------------------

(defun ses-load ()
  "Parse the current buffer and sets up buffer-local variables.  Does not
execute cell formulas or print functions."
  (widen)
  ;;Read our global parameters, which should be a 3-element list
  (goto-char (point-max))
  (search-backward ";;; Local Variables:\n" nil t)
  (backward-list 1)
  (let ((params (condition-case nil (read (current-buffer)) (error nil)))
	sym)
    (or (and (= (safe-length params) 3)
	     (numberp (car params))
	     (numberp (cadr params))
	     (> (cadr params) 0)
	     (numberp (nth 2 params))

		col (1+ col)))
	(setq end (+ end (ses-col-width col) 1))
	(put-text-property pos end 'intangible sym)))
    ;;Adding these properties did not actually alter the text
    (unless was-modified
      (set-buffer-modified-p nil)
      (buffer-disable-undo)
      (buffer-enable-undo)))
  ;;Create the underlining overlay.  It's impossible for (point) to be 2,
  ;;because column A must be at least 1 column wide.
  (setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min))))

(defun ses-cleanup ()
  "Cleanup when changing a buffer from SES mode to something else.  Delete
overlay, remove special text properties."
  (widen)
  (let ((inhibit-read-only t)
	(was-modified      (buffer-modified-p))
	end)
    ;;Delete read-only, keymap, and intangible properties
    (set-text-properties (point-min) (point-max) nil)
    ;;Delete overlay
    (mapc 'delete-overlay (overlays-in (point-min) (point-max)))
    (unless was-modified

     (unless executing-kbd-macro
       (ding))
     (message (error-message-string err))))
  nil) ;Make coverage-tester happy

(defun ses-header-string-left-offset ()
  "Number of characters in left fringe and left scrollbar (if any)."
  (let ((left-fringe    (round (or (frame-parameter nil 'left-fringe) 0)
			       (frame-char-width)))
	(left-scrollbar (if (not (eq (frame-parameter nil
						      'vertical-scroll-bars)
				     'left))
			    0
			  (let ((x (frame-parameter nil 'scroll-bar-width)))
			    ;;Non-toolkil bar is always 14 pixels?
			    (unless x (setq x 14))
			    ;;Always round up
			    (ceiling x (frame-char-width))))))
    (+ left-fringe left-scrollbar)))

(defun ses-create-header-string ()
  "Sets up `ses--header-string' as the buffer's header line, based on the
current set of columns and window-scroll position."
  (let* ((left-offset (ses-header-string-left-offset))
	 (totwidth (- left-offset (window-hscroll)))
	 result width result x)
    ;;Leave room for the left-side fringe and scrollbar
    (push (make-string left-offset ? ) result)
    (dotimes (col ses--numcols)
      (setq width    (ses-col-width col)
	    totwidth (+ totwidth width 1))
      (if (= totwidth (+ left-offset 1))
	  ;;Scrolled so intercolumn space is leftmost
	  (push " " result))
      (when (> totwidth (+ left-offset 1))
	(if (> ses--header-row 0)
	    (save-excursion
	      (ses-goto-print (1- ses--header-row) col)
	      (setq x (buffer-substring-no-properties (point)
						      (+ (point) width)))
	      (if (>= width (- totwidth left-offset))
		  (setq x (substring x (- width totwidth left-offset -1))))
	      (push (propertize x 'face ses-box-prop) result))
	  (setq x (ses-column-letter col))
	  (push (propertize x 'face ses-box-prop) result)
	  (push (propertize (make-string (- width (length x)) ?.)
			    'display    `((space :align-to ,(1- totwidth)))
			    'face       ses-box-prop)
		result))
	;;Allow the following space to be squished to make room for the 3-D box
	;;Coverage test ignores properties, thinks this is always a space!
	(push (1value (propertize " " 'display `((space :align-to ,totwidth))))
	      result)))
    (if (> ses--header-row 0)

			  'display '((height (- 1))))
	      result))
    (setq ses--header-string (apply 'concat (nreverse result)))))


;;;----------------------------------------------------------------------------
;;;; Redisplay and recalculation
;;;----------------------------------------------------------------------------

(defun ses-jump (sym)
  "Move point to cell SYM."
  (interactive "SJump to cell: ")
  (let ((rowcol (ses-sym-rowcol sym)))

(defun ses-reconstruct-all ()
  "Reconstruct buffer based on cell data stored in Emacs variables."
  (interactive "*")
  (ses-begin-change)
  ;;Reconstruct reference lists.
  (let (refs x yrow ycol)
    ;;Delete old reference lists
    (ses-dotimes-msg (row ses--numrows) "Deleting references..."
      (dotimes (col ses--numcols)
	(ses-set-cell row col 'references nil)))
    ;;Create new reference lists

		ycol (cdr x))
	  (ses-set-cell yrow ycol 'references
			(cons (ses-cell-symbol row col)
			      (ses-cell-references yrow ycol)))))))
  ;;Delete everything and reconstruct basic data area
  (if (< (point-max) (buffer-size))
      (setq ses--deferred-narrow t))
  (widen)
  (let ((inhibit-read-only t))
    (goto-char (point-max))
    (if (search-backward ";;; Local Variables:\n" nil t)
	(delete-region (point-min) (point))
      ;;Buffer is quite screwed up - can't even save the user-specified locals
      (delete-region (point-min) (point-max))
      (insert ses-initial-file-trailer)
      (goto-char (point-min)))

  (ses-setup)
  (ses-recalculate-all)
  (goto-char (point-min)))


;;;----------------------------------------------------------------------------
;;;; Input of cell formulas
;;;----------------------------------------------------------------------------

(defun ses-edit-cell (row col newval)
  "Display current cell contents in minibuffer, for editing.  Returns nil if
cell formula was unsafe and user declined confirmation."
  (interactive

      (ses-set-curcell)
      (let ((rowcol (ses-sym-rowcol ses--curcell)))
	(ses-clear-cell (car rowcol) (cdr rowcol))))))


;;;----------------------------------------------------------------------------
;;;; Input of cell-printer functions
;;;----------------------------------------------------------------------------

(defun ses-read-printer (prompt default)
  "Common code for `ses-read-cell-printer', `ses-read-column-printer', and `ses-read-default-printer'.
PROMPT should end with \": \".  Result is t if operation was cancelled."
  (barf-if-buffer-read-only)

one argument, or a symbol that names a function of one argument.  In the
latter two cases, the function's result should be either a string (will be
right-justified) or a list of one string (will be left-justified)."
  (interactive
   (let ((default t)
	 prompt x)
     (ses-check-curcell 'range)
     ;;Default is none if not all cells in range have same printer
     (catch 'ses-read-cell-printer
       (ses-dorange ses--curcell
	 (setq x (ses-cell-printer row col))

    (ses-begin-change)
    (ses-set-parameter 'ses--default-printer newval)
    (ses-reprint-all t)))


;;;----------------------------------------------------------------------------
;;;; Spreadsheet size adjustments
;;;----------------------------------------------------------------------------

(defun ses-insert-row (count)
  "Insert a new row before the current one.  With prefix, insert COUNT rows
before current one."
  (interactive "*p")

    (ses-dotimes-msg (x count) "Inserting row..."
      ;;Create a row of empty cells.  The `symbol' fields will be set by
      ;;the call to ses-relocate-all.
      (setq newrow (make-vector ses--numcols nil))
      (dotimes (col ses--numcols)
	(aset newrow col (make-vector ses-cell-size nil)))
      (setq ses--cells (ses-vector-insert ses--cells row newrow))
      (push `(ses-vector-delete ses--cells ,row 1) buffer-undo-list)
      (insert ses--blank-line))
    ;;Insert empty lines in cell data area (will be replaced by
    ;;ses-relocate-all)

  (interactive "*p")
  (ses-check-curcell)
  (or (> count 0) (signal 'args-out-of-range nil))
  (let ((inhibit-quit t)
	(inhibit-read-only t)
	(row (car (ses-sym-rowcol ses--curcell)))
	pos)
    (setq count (min count (- ses--numrows row)))
    (ses-begin-change)
    (ses-set-parameter 'ses--numrows (- ses--numrows count))
    ;;Delete lines from print area
    (ses-goto-print row 0)

  ;;Reconstruct attributes
  (ses-setup)
  (ses-jump-safe ses--curcell))

(defun ses-insert-column (count &optional col width printer)
  "Insert a new column before COL (default is the current one).  With prefix,
insert COUNT columns before current one.  If COL is specified, the new
column(s) get the specified WIDTH and PRINTER (otherwise they're taken from
the current column)."
  (interactive "*p")
  (ses-check-curcell)
  (or (> count 0) (signal 'args-out-of-range nil))
  (or col
      (setq col     (cdr (ses-sym-rowcol ses--curcell))

	(and (< (1+ col) ses--numcols) (eq (ses-cell-value row col) '*skip*)
	     ;;Inserting in the middle of a spill-over
	     (setq has-skip t))
	(ses-aset-with-undo ses--cells row
			    (ses-vector-insert (aref ses--cells row)
					       col
					      (make-vector ses-cell-size nil)))
	;;Insert empty lines in cell data area (will be replaced by
	;;ses-relocate-all)
	(ses-goto-data row col)
	(insert ?\n))
      ;;Insert column width and printer

  (or (> count 0) (signal 'args-out-of-range nil))
  (let ((inhibit-quit t)
	(inhibit-read-only t)
	(rowcol  (ses-sym-rowcol ses--curcell))
	(width 0)
	new col origrow has-skip)
    (setq origrow (car rowcol)
	  col     (cdr rowcol)
	  count   (min count (- ses--numcols col)))
    (if (= count ses--numcols)
	(error "Can't delete all columns!"))

      (ses-set-parameter 'ses--col-widths newwidth col))
    (dotimes (row ses--numrows)
      (ses-print-cell-new-width row col))))


;;;----------------------------------------------------------------------------
;;;; Cut and paste, import and export
;;;----------------------------------------------------------------------------

(defadvice copy-region-as-kill (around ses-copy-region-as-kill
				activate preactivate)
  "It doesn't make sense to copy read-only or intangible attributes into the
kill ring.  It probably doesn't make sense to copy keymap properties.

	(push "\n" result))))
    (setq result (apply 'concat (nreverse result)))
    (kill-new result)))


;;;----------------------------------------------------------------------------
;;;; Other user commands
;;;----------------------------------------------------------------------------

(defun ses-unset-header-row ()
  "Select the default header row."
  (interactive)
  (ses-set-header-row 0))

  (interactive "*e")
  (mouse-set-point event)
  (ses-insert-ses-range))


;;;----------------------------------------------------------------------------
;;;; Checking formulas for safety
;;;----------------------------------------------------------------------------

(defun ses-safe-printer (printer)
  "Returns PRINTER if safe, or the substitute printer `ses-unsafe' otherwise."
  (if (or (stringp printer)
	  (stringp (car-safe printer))

	t
      (y-or-n-p (format "Formula %S\nmight be unsafe %S.  Process it? "
			formula checker)))))


;;;----------------------------------------------------------------------------
;;;; Standard formulas
;;;----------------------------------------------------------------------------

(defmacro ses-range (from to)
  "Expands to a list of cell-symbols for the range.  The range automatically
expands to include any new row or column inserted into its middle.  The SES
library code specifically looks for the symbol `ses-range', so don't create an

(defun ses-delete-blanks (&rest args)
  "Return ARGS reversed, with the blank elements (nil and *skip*) removed."
  (let (result)
    (dolist (cur args)
      (and cur (not (eq cur '*skip*))
	   (push cur result)))
    result))

(defun ses+ (&rest args)
  "Compute the sum of the arguments, ignoring blanks."
  (apply '+ (apply 'ses-delete-blanks args)))

;;All standard formulas are safe
(dolist (x '(ses-range ses-delete-blanks ses+ ses-average ses-select))
  (put x 'side-effect-free t))


;;;----------------------------------------------------------------------------
;;;; Standard print functions
;;;----------------------------------------------------------------------------

;;These functions use the variables 'row' and 'col' that are
;;dynamically bound by ses-print-cell.  We define these varables at
;;compile-time to make the compiler happy.
(eval-when-compile

(dolist (x (cons 'ses-unsafe ses-standard-printer-functions))
  (put x 'side-effect-free t))

(provide 'ses)

;;; arch-tag: 88c1ccf0-4293-4824-8c5d-0757b52217f3
;; ses.el ends here.

58409:924fa48ab4bf

;;; ses.el -- Simple Emacs Spreadsheet  -*- coding: utf-8 -*-

;; Copyright (C) 2002,03,04  Free Software Foundation, Inc.

;; Author: Jonathan Yavner <[e-mail]>
;; Maintainer: Jonathan Yavner <[e-mail]>

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; To-do list:

;; * Use $ or … for truncated fields
;; * Add command to make a range of columns be temporarily invisible.
;; * Allow paste of one cell to a range of cells -- copy formula to each.
;; * Do something about control characters & octal codes in cell print
;;   areas.  Use string-width?

;; * Faces (colors & styles) in print cells.
;; * Move a column by dragging its letter in the header line.
;; * Left-margin column for row number.
;; * Move a row by dragging its number in the left-margin.


;;; Code:

(require 'unsafep)


;;----------------------------------------------------------------------------
;; User-customizable variables
;;----------------------------------------------------------------------------

(defgroup ses nil
  "Simple Emacs Spreadsheet"
  :group  'applications
  :prefix "ses-"

  :type  '(choice string
		  (list :tag "Parenthesized string" string)
		  function))

(defcustom ses-after-entry-functions '(forward-char)
  "Things to do after entering a value into a cell.
An abnormal hook that usually runs a cursor-movement function.
Each function is called with ARG=1."
  :group 'ses
  :type 'hook
  :options '(forward-char backward-char next-line previous-line))

(defcustom ses-mode-hook nil
  "Hook functions to be run upon entering SES mode."
  :group 'ses
  :type 'hook)


;;----------------------------------------------------------------------------
;; Global variables and constants
;;----------------------------------------------------------------------------

(defvar ses-read-cell-history nil
  "List of formulas that have been typed in.")

(defvar ses-read-printer-history nil

(easy-menu-define ses-header-line-menu nil
  "Context menu when mouse-3 is used on the header-line in an SES buffer."
  '("SES header row"
    ["Set current row" ses-set-header-row t]
    ["Unset row" ses-unset-header-row (> ses--header-row 0)]))

(defconst ses-mode-map
  (let ((keys `("\C-c\M-\C-l" ses-reconstruct-all
		"\C-c\C-l"    ses-recalculate-all
		"\C-c\C-n"    ses-renarrow-buffer

    (define-key map "T" (cons " tab-formulas" 'ses-export-tsf))
    (define-key map "t" (cons " tab-values" 'ses-export-tsv))
    map))

(defconst ses-print-data-boundary "\n\014\n"
  "Marker string denoting the boundary between print area and data area.")

(defconst ses-initial-global-parameters
  "\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n"
  "Initial contents for the three-element list at the bottom of the data area.")

(defconst ses-initial-file-trailer
  ";; Local Variables:\n;; mode: ses\n;; End:\n"
  "Initial contents for the file-trailer area at the bottom of the file.")

(defconst ses-initial-file-contents
  (concat "       \n" ;One blank cell in print area
	  ses-print-data-boundary

	  "(ses-header-row 0)\n"
	  ses-initial-global-parameters
	  ses-initial-file-trailer)
  "The initial contents of an empty spreadsheet.")

(defconst ses-paramlines-plist
  '(ses--col-widths  2 ses--col-printers  3 ses--default-printer  4
    ses--header-row  5 ses--file-format   8 ses--numrows          9
    ses--numcols    10)
  "Offsets from last cell line to various parameter lines in the data area

  (dolist (x ses-localvars)
    (make-local-variable x)
    (set x nil)))


;;
;;  "Side-effect variables".  They are set in one function, altered in
;;  another as a side effect, then read back by the first, as a way of
;;  passing back more than one value.  These declarations are just to make
;;  the compiler happy, and to conform to standard Emacs-Lisp practice (I
;;  think the make-local-variable trick above is cleaner).
;;

(defvar ses-relocate-return nil
  "Set by `ses-relocate-formula' and `ses-relocate-range', read by
`ses-relocate-all'.  Set to 'delete if a cell-reference was deleted from a
formula--so the formula needs recalculation.  Set to 'range if the size of a

(defvar ses-start-time nil
  "Time when current operation started.  Used by `ses-time-check' to decide
when to emit a progress message.")


;;----------------------------------------------------------------------------
;; Macros
;;----------------------------------------------------------------------------

(defmacro ses-get-cell (row col)
  "Return the cell structure that stores information about cell (ROW,COL)."
  `(aref (aref ses--cells ,row) ,col))

;; We might want to use defstruct here, but cells are explicitly used as
;; arrays in ses-set-cell, so we'd need to fix this first.  --Stef
(defsubst ses-make-cell (&optional symbol formula printer references)
  (vector symbol formula printer references))

(defmacro ses-cell-symbol (row &optional col)
  "From a CELL or a pair (ROW,COL), get the symbol that names the local-variable holding its value.  (0,0) => A1."
  `(aref ,(if col `(ses-get-cell ,row ,col) row) 0))

	(stringp printer)
	(eq safe-functions t)
	(setq printer `(ses-safe-printer ,printer)))
    (aset (aref ses--cells (car rowcol))
	  (cdr rowcol)
	  (ses-make-cell sym formula printer references)))
  (set sym value)
  sym)

(defmacro ses-column-widths (widths)
  "Load the vector of column widths from the spreadsheet file.  This is a

(defmacro noreturn (form)
  "For code-coverage testing, indicate that FORM will always signal an error."
  form)


;;----------------------------------------------------------------------------
;; Utility functions
;;----------------------------------------------------------------------------

(defun ses-vector-insert (array idx new)
  "Create a new vector which is one larger than ARRAY and has NEW inserted
before element IDX."
  (let* ((len    (length array))

	      xcol (+ col mincol)
	      sym  (ses-create-cell-symbol xrow xcol))
	(put sym 'ses-cell (cons xrow xcol))
	(make-local-variable sym)))))

;;We do not delete the ses-cell properties for the cell-variables, in case a
;;formula that refers to this cell is in the kill-ring and is later pasted
;;back in.
(defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol)
  "Destroy buffer-local variables for cells.  This is undoable."
  (let (sym)
    (dotimes (row (1+ (- maxrow minrow)))
      (dotimes (col (1+ (- maxcol mincol)))

    (message format (eval arg))
    (setq ses-start-time (float-time)))
  nil)


;;----------------------------------------------------------------------------
;; The cells
;;----------------------------------------------------------------------------

(defun ses-set-cell (row col field val)
  "Install VAL as the contents for field FIELD (named by a quoted symbol) of
cell (ROW,COL).  This is undoable.  The cell's data will be updated through
`post-command-hook'."

  Any cells that depend on this cell are queued for update after the end of
processing for the current keystroke, unless the new value is the same as
the old and FORCE is nil."
  (let ((cell (ses-get-cell row col))
	formula-error printer-error)
    (let ((oldval  (ses-cell-value   cell))
	  (formula (ses-cell-formula cell))
	  newval)
      (if (eq (car-safe formula) 'ses-safe-formula)
	  (ses-set-cell row col 'formula (ses-safe-formula (cadr formula))))
      (condition-case sig

    ;;Can't use save-excursion here: if the cell under point is
    ;;updated, save-excusion's marker will move past the cell.
    (goto-char pos)))


;;----------------------------------------------------------------------------
;; The print area
;;----------------------------------------------------------------------------

(defun ses-in-print-area ()
  "Returns t if point is in print area of spreadsheet."
  (eq (get-text-property (point) 'keymap) 'ses-mode-print-map))

;;We turn off point-motion-hooks and explicitly position the cursor, in case
;;the intangible properties have gotten screwed up (e.g., when
;;ses-goto-print is called during a recursive ses-print-cell).
(defun ses-goto-print (row col)
  "Move point to print area for cell (ROW,COL)."
  (let ((inhibit-point-motion-hooks t))
    (goto-char (point-min))
    (forward-line row)

	(error "Can't use a range")))
   ((memq 'needrange args)
    (error "Need a range"))))

(defun ses-print-cell (row col)
  "Format and print the value of cell (ROW,COL) to the print area.
Use the cell's printer function.  If the cell's new print form is too wide,
it will spill over into the following cell, but will not run off the end of the
row or overwrite the next non-nil field.  Result is nil for normal operation,
or the error signal if the printer function failed and the cell was formatted
with \"%s\".  If the cell's value is *skip*, nothing is printed because the
preceding cell has spilled over."
  (catch 'ses-print-cell
    (let* ((cell    (ses-get-cell row col))
	   (value   (ses-cell-value cell))

    (backward-char 1)
    (let ((rowcol (ses-sym-rowcol (get-text-property (point) 'intangible))))
      (ses-print-cell (car rowcol) (cdr rowcol)))))


;;----------------------------------------------------------------------------
;; The data area
;;----------------------------------------------------------------------------

(defun ses-narrowed-p () (/= (- (point-max) (point-min)) (buffer-size)))

(defun ses-goto-data (def &optional col)
  "Move point to data area for (DEF,COL).  If DEF is a row
number, COL is the column number for a data cell -- otherwise DEF
is one of the symbols ses--col-widths, ses--col-printers,
ses--default-printer, ses--numrows, or ses--numcols."
  (if (ses-narrowed-p)
      (setq ses--deferred-narrow t))
  (widen)
  (let ((inhibit-point-motion-hooks t)) ;In case intangible attrs are wrong
    (goto-char (point-min))
    (if col

    (setq def (plist-get ses-paramlines-plist def))
    (or def (signal 'args-out-of-range nil))
    (forward-line (+ (* ses--numrows (+ ses--numcols 2)) def)))))

(defun ses-set-parameter (def value &optional elem)
  "Set parameter DEF to VALUE (with undo) and write the value to the data area.
See `ses-goto-data' for meaning of DEF.  Newlines in the data are escaped.
If ELEM is specified, it is the array subscript within DEF to be set to VALUE."
  (save-excursion
    ;;We call ses-goto-data early, using the old values of numrows and
    ;;numcols in case one of them is being changed.
    (ses-goto-data def)
    (if elem

			  def)))
      (delete-region (point) (line-end-position))
      (insert (format fmt (symbol-value def))))))

(defun ses-write-cells ()
  "Write cells in `ses--deferred-write' from local variables to data area.
Newlines in the data are escaped."
  (let* ((inhibit-read-only t)
	 (print-escape-newlines t)
	 rowcol row col cell sym formula printer text)
    (setq ses-start-time (float-time))
    (with-temp-message " "

	  (delete-region (point) (line-end-position))
	  (insert text)))
      (message " "))))


;;----------------------------------------------------------------------------
;; Formula relocation
;;----------------------------------------------------------------------------

(defun ses-formula-references (formula &optional result-so-far)
  "Produce a list of symbols for cells that this formula's value
refers to.  For recursive calls, RESULT-SO-FAR is the list being constructed,
or t to get a wrong-type-argument error when the first reference is found."

		reform (cdr reform))
	  (ses-cell-set-formula row col (ses-cell-formula row col))))
      (message nil))))


;;----------------------------------------------------------------------------
;; Undo control
;;----------------------------------------------------------------------------

(defadvice undo-more (around ses-undo-more activate preactivate)
  "Define a meaning for conses in buffer-undo-list whose car is a symbol
other than t or nil.  To undo these, apply the car--a function--to the
cdr--its arglist."

	     (apply (car ses-x) (cdr ses-x)))))
    (if (not (eq major-mode 'ses-mode))
	ad-do-it
      ;;Here is some extra code for SES mode.
      (setq ses--deferred-narrow
	    (or ses--deferred-narrow (ses-narrowed-p)))
      (widen)
      (condition-case x
	  ad-do-it
	(error
	 ;;Restore narrow if appropriate

    (push `(ses-aset-with-undo ,array ,idx ,(aref array idx)) buffer-undo-list)
    (aset array idx newval)
    t))


;;----------------------------------------------------------------------------
;; Startup for major mode
;;----------------------------------------------------------------------------

(defun ses-load ()
  "Parse the current buffer and sets up buffer-local variables.  Does not
execute cell formulas or print functions."
  (widen)
  ;;Read our global parameters, which should be a 3-element list
  (goto-char (point-max))
  (search-backward ";; Local Variables:\n" nil t)
  (backward-list 1)
  (let ((params (condition-case nil (read (current-buffer)) (error nil))))
    (or (and (= (safe-length params) 3)
	     (numberp (car params))
	     (numberp (cadr params))
	     (> (cadr params) 0)
	     (numberp (nth 2 params))

		col (1+ col)))
	(setq end (+ end (ses-col-width col) 1))
	(put-text-property pos end 'intangible sym)))
    ;;Adding these properties did not actually alter the text
    (unless was-modified
      (restore-buffer-modified-p nil)
      (buffer-disable-undo)
      (buffer-enable-undo)))
  ;;Create the underlining overlay.  It's impossible for (point) to be 2,
  ;;because column A must be at least 1 column wide.
  (setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min))))

(defun ses-cleanup ()
  "Cleanup when changing a buffer from SES mode to something else.  Delete
overlay, remove special text properties."
  (widen)
  (let ((inhibit-read-only t)
	(was-modified      (buffer-modified-p)))
    ;;Delete read-only, keymap, and intangible properties
    (set-text-properties (point-min) (point-max) nil)
    ;;Delete overlay
    (mapc 'delete-overlay (overlays-in (point-min) (point-max)))
    (unless was-modified

     (unless executing-kbd-macro
       (ding))
     (message (error-message-string err))))
  nil) ;Make coverage-tester happy

(defun ses-create-header-string ()
  "Set up `ses--header-string' as the buffer's header line.
Based on the current set of columns and `window-hscroll' position."
  (let ((totwidth (- (window-hscroll)))
	result width x)
    ;;Leave room for the left-side fringe and scrollbar
    (push (propertize " " 'display '((space :align-to 0))) result)
    (dotimes (col ses--numcols)
      (setq width    (ses-col-width col)
	    totwidth (+ totwidth width 1))
      (if (= totwidth 1)
	  ;;Scrolled so intercolumn space is leftmost
	  (push " " result))
      (when (> totwidth 1)
	(if (> ses--header-row 0)
	    (save-excursion
	      (ses-goto-print (1- ses--header-row) col)
	      (setq x (buffer-substring-no-properties (point)
						      (+ (point) width)))
	      ;; Strip trailing space.
	      (if (string-match "[ \t]+\\'" x)
		  (setq x (substring x 0 (match-beginning 0))))
	      ;; Cut off excess text.
	      (if (>= (length x) totwidth)
		  (setq x (substring x 0 (- totwidth -1)))))
	  (setq x (ses-column-letter col)))
	  (push (propertize x 'face ses-box-prop) result)
	(push (propertize "."
			    'display    `((space :align-to ,(1- totwidth)))
			    'face       ses-box-prop)
	      result)
	;;Allow the following space to be squished to make room for the 3-D box
	;;Coverage test ignores properties, thinks this is always a space!
	(push (1value (propertize " " 'display `((space :align-to ,totwidth))))
	      result)))
    (if (> ses--header-row 0)

			  'display '((height (- 1))))
	      result))
    (setq ses--header-string (apply 'concat (nreverse result)))))


;;----------------------------------------------------------------------------
;; Redisplay and recalculation
;;----------------------------------------------------------------------------

(defun ses-jump (sym)
  "Move point to cell SYM."
  (interactive "SJump to cell: ")
  (let ((rowcol (ses-sym-rowcol sym)))

(defun ses-reconstruct-all ()
  "Reconstruct buffer based on cell data stored in Emacs variables."
  (interactive "*")
  (ses-begin-change)
  ;;Reconstruct reference lists.
  (let (x yrow ycol)
    ;;Delete old reference lists
    (ses-dotimes-msg (row ses--numrows) "Deleting references..."
      (dotimes (col ses--numcols)
	(ses-set-cell row col 'references nil)))
    ;;Create new reference lists

		ycol (cdr x))
	  (ses-set-cell yrow ycol 'references
			(cons (ses-cell-symbol row col)
			      (ses-cell-references yrow ycol)))))))
  ;;Delete everything and reconstruct basic data area
  (if (ses-narrowed-p)
      (setq ses--deferred-narrow t))
  (widen)
  (let ((inhibit-read-only t))
    (goto-char (point-max))
    (if (search-backward ";; Local Variables:\n" nil t)
	(delete-region (point-min) (point))
      ;;Buffer is quite screwed up - can't even save the user-specified locals
      (delete-region (point-min) (point-max))
      (insert ses-initial-file-trailer)
      (goto-char (point-min)))

  (ses-setup)
  (ses-recalculate-all)
  (goto-char (point-min)))


;;----------------------------------------------------------------------------
;; Input of cell formulas
;;----------------------------------------------------------------------------

(defun ses-edit-cell (row col newval)
  "Display current cell contents in minibuffer, for editing.  Returns nil if
cell formula was unsafe and user declined confirmation."
  (interactive

      (ses-set-curcell)
      (let ((rowcol (ses-sym-rowcol ses--curcell)))
	(ses-clear-cell (car rowcol) (cdr rowcol))))))


;;----------------------------------------------------------------------------
;; Input of cell-printer functions
;;----------------------------------------------------------------------------

(defun ses-read-printer (prompt default)
  "Common code for `ses-read-cell-printer', `ses-read-column-printer', and `ses-read-default-printer'.
PROMPT should end with \": \".  Result is t if operation was cancelled."
  (barf-if-buffer-read-only)

one argument, or a symbol that names a function of one argument.  In the
latter two cases, the function's result should be either a string (will be
right-justified) or a list of one string (will be left-justified)."
  (interactive
   (let ((default t)
	 x)
     (ses-check-curcell 'range)
     ;;Default is none if not all cells in range have same printer
     (catch 'ses-read-cell-printer
       (ses-dorange ses--curcell
	 (setq x (ses-cell-printer row col))

    (ses-begin-change)
    (ses-set-parameter 'ses--default-printer newval)
    (ses-reprint-all t)))


;;----------------------------------------------------------------------------
;; Spreadsheet size adjustments
;;----------------------------------------------------------------------------

(defun ses-insert-row (count)
  "Insert a new row before the current one.  With prefix, insert COUNT rows
before current one."
  (interactive "*p")

    (ses-dotimes-msg (x count) "Inserting row..."
      ;;Create a row of empty cells.  The `symbol' fields will be set by
      ;;the call to ses-relocate-all.
      (setq newrow (make-vector ses--numcols nil))
      (dotimes (col ses--numcols)
	(aset newrow col (ses-make-cell)))
      (setq ses--cells (ses-vector-insert ses--cells row newrow))
      (push `(ses-vector-delete ses--cells ,row 1) buffer-undo-list)
      (insert ses--blank-line))
    ;;Insert empty lines in cell data area (will be replaced by
    ;;ses-relocate-all)

  (interactive "*p")
  (ses-check-curcell)
  (or (> count 0) (signal 'args-out-of-range nil))
  (let ((inhibit-quit t)
	(inhibit-read-only t)
	(row (car (ses-sym-rowcol ses--curcell))))
    (setq count (min count (- ses--numrows row)))
    (ses-begin-change)
    (ses-set-parameter 'ses--numrows (- ses--numrows count))
    ;;Delete lines from print area
    (ses-goto-print row 0)

  ;;Reconstruct attributes
  (ses-setup)
  (ses-jump-safe ses--curcell))

(defun ses-insert-column (count &optional col width printer)
  "Insert a new column before COL (default is the current one).
With prefix, insert COUNT columns before current one.
If COL is specified, the new column(s) get the specified WIDTH and PRINTER
\(otherwise they're taken from the current column)."
  (interactive "*p")
  (ses-check-curcell)
  (or (> count 0) (signal 'args-out-of-range nil))
  (or col
      (setq col     (cdr (ses-sym-rowcol ses--curcell))

	(and (< (1+ col) ses--numcols) (eq (ses-cell-value row col) '*skip*)
	     ;;Inserting in the middle of a spill-over
	     (setq has-skip t))
	(ses-aset-with-undo ses--cells row
			    (ses-vector-insert (aref ses--cells row)
					       col (ses-make-cell)))
	;;Insert empty lines in cell data area (will be replaced by
	;;ses-relocate-all)
	(ses-goto-data row col)
	(insert ?\n))
      ;;Insert column width and printer

  (or (> count 0) (signal 'args-out-of-range nil))
  (let ((inhibit-quit t)
	(inhibit-read-only t)
	(rowcol  (ses-sym-rowcol ses--curcell))
	(width 0)
	col origrow has-skip)
    (setq origrow (car rowcol)
	  col     (cdr rowcol)
	  count   (min count (- ses--numcols col)))
    (if (= count ses--numcols)
	(error "Can't delete all columns!"))

      (ses-set-parameter 'ses--col-widths newwidth col))
    (dotimes (row ses--numrows)
      (ses-print-cell-new-width row col))))


;;----------------------------------------------------------------------------
;; Cut and paste, import and export
;;----------------------------------------------------------------------------

(defadvice copy-region-as-kill (around ses-copy-region-as-kill
				activate preactivate)
  "It doesn't make sense to copy read-only or intangible attributes into the
kill ring.  It probably doesn't make sense to copy keymap properties.

	(push "\n" result))))
    (setq result (apply 'concat (nreverse result)))
    (kill-new result)))


;;----------------------------------------------------------------------------
;; Other user commands
;;----------------------------------------------------------------------------

(defun ses-unset-header-row ()
  "Select the default header row."
  (interactive)
  (ses-set-header-row 0))

  (interactive "*e")
  (mouse-set-point event)
  (ses-insert-ses-range))


;;----------------------------------------------------------------------------
;; Checking formulas for safety
;;----------------------------------------------------------------------------

(defun ses-safe-printer (printer)
  "Returns PRINTER if safe, or the substitute printer `ses-unsafe' otherwise."
  (if (or (stringp printer)
	  (stringp (car-safe printer))

	t
      (y-or-n-p (format "Formula %S\nmight be unsafe %S.  Process it? "
			formula checker)))))


;;----------------------------------------------------------------------------
;; Standard formulas
;;----------------------------------------------------------------------------

(defmacro ses-range (from to)
  "Expands to a list of cell-symbols for the range.  The range automatically
expands to include any new row or column inserted into its middle.  The SES
library code specifically looks for the symbol `ses-range', so don't create an

(defun ses-delete-blanks (&rest args)
  "Return ARGS reversed, with the blank elements (nil and *skip*) removed."
  (let (result)
    (dolist (cur args)
      (unless (memq cur '(nil *skip*))
	(push cur result)))
    result))

(defun ses+ (&rest args)
  "Compute the sum of the arguments, ignoring blanks."
  (apply '+ (apply 'ses-delete-blanks args)))

;;All standard formulas are safe
(dolist (x '(ses-range ses-delete-blanks ses+ ses-average ses-select))
  (put x 'side-effect-free t))


;;----------------------------------------------------------------------------
;; Standard print functions
;;----------------------------------------------------------------------------

;;These functions use the variables 'row' and 'col' that are
;;dynamically bound by ses-print-cell.  We define these varables at
;;compile-time to make the compiler happy.
(eval-when-compile

(dolist (x (cons 'ses-unsafe ses-standard-printer-functions))
  (put x 'side-effect-free t))

(provide 'ses)

;; arch-tag: 88c1ccf0-4293-4824-8c5d-0757b52217f3
;;; ses.el ends here