cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/kotl/kfile.el

   1 ;;; kfile.el --- Save and restore kotls from files.
   2
   3 ;; Copyright (C) 1995, 2004, 2006 Free Software Foundation, Inc.
   4 ;; Developed with support from Motorola Inc.
   5
   6 ;; Author: Bob Weiner, Brown U.
   7 ;;         Kellie Clark
   8 ;; Maintainer: Mats Lidell <matsl@contactor.se>
   9 ;; Keywords: outlines, wp
  10
  11 ;; This file is part of GNU Hyperbole.
  12
  13 ;; GNU Hyperbole is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 3, or (at
  16 ;; your option) any later version.
  17
  18 ;; GNU Hyperbole is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;;; Code:
  31
  32 ;;;
  33 ;;; Other required Elisp libraries
  34 ;;;
  35
  36 (mapcar 'require '(kproperty kotl-mode))
  37
  38 ;;;
  39 ;;; Public variables
  40 ;;;
  41
  42 (defconst kfile:version "Kotl-4.0"
  43   "Version number of persistent data format used for saving koutlines.")
  44
  45 ;;;
  46 ;;; Entry Points
  47 ;;;
  48
  49 ;;;###autoload
  50 (defun kfile:find (file-name)
  51   "Find a file FILE-NAME containing a kotl or create one if none exists.
  52 Return the new kview."
  53   (interactive
  54    (list (kfile:read-name
  55           "Find koutline file: " nil)))
  56   (let ((existing-file (file-exists-p file-name))
  57         buffer)
  58     (and existing-file
  59          (not (file-readable-p file-name))
  60          (error
  61           "(kfile:find): \"%s\" is not readable.  Check permissions."
  62           file-name))
  63     (setq buffer (find-file file-name))
  64     ;; Finding the file may have already done a kfile:read as invoked through
  65     ;; kotl-mode via a file local variable setting.  If so, don't read it
  66     ;; again.
  67     (if (kview:is-p kview)
  68         nil
  69       (kfile:read buffer existing-file))
  70     (or (eq major-mode 'kotl-mode) (kotl-mode))
  71     kview))
  72
  73 ;;;###autoload
  74 (defun kfile:view (file-name)
  75   "View an existing kotl version-2 file FILE-NAME in a read-only mode."
  76   (interactive
  77    (list (kfile:read-name
  78           "View koutline file: " t)))
  79   (let ((existing-file (file-exists-p file-name)))
  80     (if existing-file
  81         (if (not (file-readable-p file-name))
  82             (error
  83              "(kfile:view): \"%s\" is not readable.  Check permissions."
  84              file-name))
  85       (error "(kfile:view): \"%s\" does not exist."))
  86     (view-file file-name))
  87     (kfile:narrow-to-kcells)
  88     (goto-char (point-min)))
  89
  90 ;;;
  91 ;;; Public functions
  92 ;;;
  93
  94 (defun kfile:create (buffer)
  95   "Create a new koutline file attached to BUFFER, with a single empty level 1 kotl cell.
  96 Return file's kview."
  97   (or buffer (setq buffer (current-buffer)))
  98   (if (not (bufferp buffer))
  99       (error "(kfile:create): Invalid buffer argument, %s" buffer))
 100   (set-buffer buffer)
 101   (if buffer-read-only
 102       (error "(kfile:create): %s is read-only" buffer))
 103   (widen)
 104
 105   (let ((empty-p (zerop (buffer-size)))
 106         import-from view standard-output)
 107
 108     (if (not empty-p)
 109         ;; This is a foreign file whose elements must be converted into
 110         ;; koutline cells.
 111         (progn (setq import-from (kimport:copy-and-set-buffer buffer))
 112                (set-buffer buffer)
 113                (erase-buffer))) ;; We copied the contents to `import-from'.
 114
 115     (setq view (kview:create (buffer-name buffer))
 116           standard-output (current-buffer))
 117     (goto-char (point-min))
 118     (princ ";; -*- Mode: kotl -*- \n")
 119     (prin1 kfile:version)
 120     (princ " ;; file-format\n\^_\n")
 121     ;; Ensure that last cell has two newlines after it so that
 122     ;; kfile:insert-attributes finds it.
 123     (goto-char (point-max))
 124     (princ "\n\n\^_\n")
 125     (princ "\^_\n;; depth-first kcell attributes\n")
 126     ;; Ensure that display is narrowed to cell region only.
 127     (kfile:narrow-to-kcells)
 128     (goto-char (point-min))
 129     (if empty-p
 130         ;; This is a new koutline file.  Always need at least one visible
 131         ;; cell within a view. Insert initial empty cell.
 132         (progn (kview:add-cell "1" 1)
 133                ;; Mark view unmodified, so if kill right away, there is no
 134                ;; prompt.
 135                (set-buffer-modified-p nil)
 136                ;; Move to first cell.
 137                (goto-char (point-min))
 138                (goto-char (kcell-view:start)))
 139       ;; Import buffer.  Next line is necessary or the importation will fail.
 140       (delete-region (point-min) (point-max))
 141       ;; Import foreign buffer as koutline cells.
 142       (kimport:file import-from (current-buffer))
 143       ;; If import buffer name starts with a space, kill it, as it is no
 144       ;; longer needed.
 145       (if (= ?\ (aref (buffer-name import-from) 0))
 146           (kill-buffer import-from)))
 147
 148     view))
 149
 150 ;;;###autoload
 151 (defun kfile:is-p ()
 152   "Iff current buffer contains an unformatted or formatted koutline, return file format version string, else nil."
 153   (let (ver-string)
 154     (save-excursion
 155       (save-restriction
 156         (widen)
 157         (goto-char (point-min))
 158         (condition-case ()
 159             (progn
 160               (setq ver-string (read (current-buffer)))
 161               (and (stringp ver-string) (string-match "^Kotl-" ver-string)
 162                    ver-string))
 163           (error nil))))))
 164
 165 (defun kfile:read (buffer existing-file-p)
 166   "Create a new kotl view by reading BUFFER or create an empty view when EXISTING-FILE-P is nil.
 167 Return the new view."
 168   (let (ver-string)
 169     (cond ((not (bufferp buffer))
 170            (error "(kfile:read): Argument must be a buffer, '%s'." buffer))
 171           ((not existing-file-p)
 172            (kfile:create buffer))
 173           ((progn
 174              (set-buffer buffer)
 175              (not (setq ver-string (kfile:is-p))))
 176            (error "(kfile:read): '%s' is not a koutline file." buffer))
 177           ((equal ver-string "Kotl-4.0")
 178            (kfile:read-v4-or-v3 buffer nil))
 179           ((equal ver-string "Kotl-3.0")
 180            (kfile:read-v4-or-v3 buffer t))
 181           ((equal ver-string "Kotl-2.0")
 182            (kfile:read-v2 buffer))
 183           ((equal ver-string "Kotl-1.0")
 184            (error "(kfile:read): V1 koutlines are no longer supported"))
 185           (t (error "(kfile:read): '%s' has unknown kotl version, %s."
 186                     buffer ver-string)))))
 187
 188 (defun kfile:read-v2 (buffer)
 189   "Create a kotl view by reading kotl version-2 BUFFER.  Return the new view."
 190   (let ((standard-input buffer)
 191         cell-count label-type label-min-width label-separator
 192         level-indent cell-data kotl-structure view kcell-list)
 193     (widen)
 194     (goto-char (point-min))
 195     ;; Skip past cell contents here.
 196     (search-forward "\n\^_" nil t 2)
 197     ;; Read rest of file data.
 198     (setq cell-count (read)
 199           label-type (read)
 200           label-min-width (read)
 201           label-separator (read)
 202           level-indent (read)
 203           cell-data (read)
 204           kotl-structure (read))
 205     ;;
 206     ;; kcell-list is a depth-first list of kcells to be attached to the cell
 207     ;; contents within the kview down below.
 208     (setq kcell-list (kfile:build-structure-v2 kotl-structure cell-data)
 209           view (kview:create (buffer-name buffer) cell-count label-type
 210                                  level-indent label-separator label-min-width))
 211     ;;
 212     (kfile:narrow-to-kcells)
 213     (goto-char (point-min))
 214     ;;
 215     ;; Add attributes to cells.
 216     (kfile:insert-attributes-v2 view kcell-list)
 217     ;;
 218     ;; Mark view unmodified and move to first cell.
 219     (set-buffer-modified-p nil)
 220     (goto-char (point-min))
 221     (goto-char (kcell-view:start))
 222     view))
 223
 224 (defun kfile:read-v4-or-v3 (buffer v3-flag)
 225   "Create a koutline view by reading version-4 BUFFER.  Return the new view.
 226 If V3-FLAG is true, read as a version-3 buffer."
 227   (let ((standard-input buffer)
 228         cell-count label-type label-min-width label-separator
 229         level-indent cell-data view)
 230     (widen)
 231     (goto-char (point-min))
 232     ;; Skip past cell contents here.
 233     (search-forward "\n\^_" nil t 2)
 234     ;; Read rest of file data.
 235     (if v3-flag
 236         nil ;; V3 files did not store viewspecs.
 237       (kvspec:initialize)
 238       (setq kvspec:current (read)))
 239     (setq cell-count (read)
 240           label-type (read)
 241           label-min-width (read)
 242           label-separator (read)
 243           level-indent (read)
 244           cell-data (read))
 245     ;;
 246     (setq view (kview:create (buffer-name buffer) cell-count label-type
 247                              level-indent label-separator label-min-width))
 248     ;;
 249     (kfile:narrow-to-kcells)
 250     (goto-char (point-min))
 251     ;;
 252     ;; Add attributes to cells.
 253     (kfile:insert-attributes-v3 view cell-data)
 254     ;;
 255     ;; Mark view unmodified and move to first cell.
 256     (set-buffer-modified-p nil)
 257     (goto-char (point-min))
 258     (goto-char (kcell-view:start))
 259     view))
 260
 261 (defun kfile:update (&optional visible-only-p)
 262   "Update kfile internal structure so that view is ready for saving to a file.
 263 Leave outline file expanded with structure data showing unless optional
 264 VISIBLE-ONLY-P is non-nil.  Signal an error if kotl is not attached to a file."
 265   (let* ((top (kview:top-cell kview))
 266          (file (kcell:get-attr top 'file))
 267          (label-type (kview:label-type kview))
 268          (label-min-width (kview:label-min-width kview))
 269          (label-separator (kview:label-separator kview))
 270          (level-indent (kview:level-indent kview))
 271          ;; If this happens to be non-nil, it is virtually impossible to save
 272          ;; a file, so ensure it is nil.
 273          (debug-on-error))
 274     (cond ((null file)
 275            (error "(kfile:update): Current outline is not attached to a file."))
 276           ((not (file-writable-p file))
 277            (error "(kfile:update): File \"%s\" is not writable." file)))
 278     (let* ((buffer-read-only)
 279            (id-counter (kcell:get-attr top 'id-counter))
 280            (kotl-data (make-vector (1+ id-counter) nil))
 281            (standard-output (current-buffer))
 282            (opoint (set-marker (make-marker) (point)))
 283            (kcell-num 1)
 284            cell)
 285       ;;
 286       ;; Prepare cell data for saving.
 287       (kfile:narrow-to-kcells)
 288       (kview:map-tree
 289         (function
 290           (lambda (view)
 291             (setq cell (kcell-view:cell))
 292             (aset kotl-data
 293                   kcell-num
 294                   (kotl-data:create cell))
 295             (setq kcell-num (1+ kcell-num))))
 296         kview t)
 297       ;; Save top cell, 0, last since above loop may increment the total
 298       ;; number of cells counter stored in it, if any invalid cells are
 299       ;; encountered.
 300       (aset kotl-data 0 (kotl-data:create top))
 301       (setq id-counter (kcell:get-attr top 'id-counter))
 302       ;;
 303       (widen)
 304       (goto-char (point-min))
 305       (if (search-forward "\n\^_\n" nil t)
 306           (delete-region (point-min) (match-end 0)))
 307       (princ ";; -*- Mode: kotl -*- \n")
 308       (prin1 kfile:version)
 309       (princ " ;; file-format\n\^_\n")
 310       ;; Skip past cells.
 311       (if (search-forward "\n\^_\n" nil t)
 312           ;; Get rid of excess blank lines after last cell.
 313           (progn (goto-char (match-beginning 0))
 314                  (skip-chars-backward "\n")
 315                  (delete-region (point) (point-max)))
 316         (goto-char (point-max)))
 317       ;; Ensure that last cell has two newlines after it so that
 318       ;; kfile:insert-attributes finds it.
 319       (princ "\n\n\^_\n")
 320       (princ (format (concat
 321                       "%S ;; kvspec:current\n%d ;; id-counter\n"
 322                       "%S ;; label-type\n%d ;; label-min-width\n"
 323                       "%S ;; label-separator\n%d ;; level-indent\n")
 324                      kvspec:current id-counter label-type label-min-width
 325                      label-separator level-indent))
 326       (princ "\^_\n;; depth-first kcell attributes\n")
 327       (kfile:pretty-print kotl-data)
 328       ;;
 329       ;; Don't re-narrow buffer by default since this is used in
 330       ;; write-contents-hooks after save-buffer has widened buffer.  If
 331       ;; buffer is narrowed here, only the narrowed portion will be saved to
 332       ;; the file.  Narrow as an option since saving only the portion of the
 333       ;; file visible in a view may be useful in some situations.
 334       (if visible-only-p (kfile:narrow-to-kcells))
 335       ;;
 336       ;; Return point to its original position as given by the opoint marker.
 337       (goto-char opoint)
 338       (set-marker opoint nil)
 339       nil)))
 340
 341 ;;; Next function is adapted from 'file-write' of GNU Emacs 19, copyright FSF,
 342 ;;; under the GPL.
 343 (defun kfile:write (file)
 344   "Write current outline to FILE."
 345   (interactive "FWrite outline file: ")
 346   (if (or (null file) (string-equal file ""))
 347       (error "(kfile:write): Invalid file name, \"%s\"" file))
 348   ;; If arg is just a directory, use same file name, but in that directory.
 349   (if (and (file-directory-p file) buffer-file-name)
 350       (setq file (concat (file-name-as-directory file)
 351                          (file-name-nondirectory buffer-file-name))))
 352   (kcell:set-attr (kview:top-cell kview) 'file file)
 353   (set-visited-file-name file)
 354   ;; Set-visited-file-name clears local-write-file-hooks that we use to save
 355   ;; koutlines properly, so reinitialize local variables.
 356   (kotl-mode)
 357   (set-buffer-modified-p t)
 358   ;; This next line must come before the save-buffer since write-file-hooks
 359   ;; can make use of it.
 360   (kview:set-buffer-name kview (buffer-name))
 361   (save-buffer))
 362
 363 ;;;
 364 ;;; Private functions
 365 ;;;
 366
 367 (defun kfile:build-structure-v2 (kotl-structure cell-data)
 368   "Build cell list from the KOTL-STRUCTURE and its CELL-DATA.
 369 Assumes all arguments are valid.  CELL-DATA is a vector of cell fields read
 370 from a koutline file.
 371
 372 Return list of outline cells in depth first order.  Invisible top cell is not
 373 included in the list."
 374   (let ((stack) (sibling-p) (cell-list) func cell)
 375     (mapcar
 376      (function
 377       (lambda (item)
 378         (setq func (cdr (assoc item
 379                                (list
 380                                 (cons "\("
 381                                       (function
 382                                        (lambda ()
 383                                          (setq stack (cons sibling-p stack)
 384                                                sibling-p nil))))
 385                                 (cons "\)"
 386                                       (function
 387                                        (lambda ()
 388                                          (setq sibling-p (car stack)
 389                                                stack (cdr stack)))))))))
 390         (cond (func (funcall func))
 391               ;; 0th cell was created with kview:create.
 392               ((equal item 0) nil)
 393               (t (setq cell (kotl-data:to-kcell-v2 (aref cell-data item))
 394                        cell-list (cons cell cell-list)
 395                        sibling-p t)
 396                  ))))
 397      kotl-structure)
 398     (nreverse cell-list)))
 399
 400 (defun kfile:insert-attributes-v2 (kview kcell-list)
 401   "Set cell attributes within kview for each element in KCELL-LIST.
 402 Assumes all cell contents are already in kview and that no cells are
 403 hidden."
 404   (let (buffer-read-only)
 405     (while
 406         (progn
 407           (skip-chars-forward "\n")
 408           ;; !!! Won't work if label-type is 'no.
 409           ;; Here we search past the cell identifier
 410           ;; for the location at which to place cell properties.
 411           ;; Be sure not to skip past a period which may terminate the label.
 412           (if (re-search-forward "[A-Za-z0-9]\\(\\.?[A-Za-z0-9]\\)*" nil t)
 413               (progn
 414                 (kproperty:set 'kcell (car kcell-list))
 415                 (setq kcell-list (cdr kcell-list))))
 416           (search-forward "\n\n" nil t)))))
 417
 418 (defun kfile:insert-attributes-v3 (kview kcell-vector)
 419   "Set cell attributes within kview for each element in KCELL-VECTOR.
 420 Assumes all cell contents are already in kview and that no cells are
 421 hidden."
 422   (let ((kcell-num 1)
 423         (buffer-read-only))
 424     (while
 425         (progn
 426           (skip-chars-forward "\n")
 427           ;; !!! Won't work if label-type is 'no.
 428           ;; Here we search past the cell identifier
 429           ;; for the location at which to place cell properties.
 430           ;; Be sure not to skip past a period which may terminate the label.
 431           (if (re-search-forward "[A-Za-z0-9]\\(\\.?[A-Za-z0-9]\\)*" nil t)
 432               (progn
 433                 (kproperty:set 'kcell
 434                                (kotl-data:to-kcell-v3
 435                                 (aref kcell-vector kcell-num)))
 436                 (setq kcell-num (1+ kcell-num))))
 437           (search-forward "\n\n" nil t)))))
 438
 439 (defun kfile:narrow-to-kcells ()
 440   "Narrow kotl file to kcell section only."
 441   (interactive)
 442   (if (kview:is-p kview)
 443       (let ((start-text) (end-text))
 444         (save-excursion
 445           (widen)
 446           (goto-char (point-min))
 447           ;; Skip to start of kcells.
 448           (if (search-forward "\n\^_" nil t)
 449               (setq start-text (1+ (match-end 0))))
 450           ;; Skip past end of kcells.
 451           (if (and start-text (search-forward "\n\^_" nil t))
 452               (setq end-text (1+ (match-beginning 0))))
 453           (if (and start-text end-text)
 454               (progn (narrow-to-region start-text end-text)
 455                      (goto-char (point-min)))
 456             (error
 457              "(kfile:narrow-to-kcells): Cannot find start or end of kcells"))
 458           ))))
 459
 460 (defun kfile:print-to-string (object)
 461   "Return a string containing OBJECT, any Lisp object, in pretty-printed form.
 462 Quoting characters are used when needed to make output that `read' can
 463 handle, whenever this is possible."
 464   (save-excursion
 465     (set-buffer (get-buffer-create " kfile:print-to-string"))
 466     (let ((emacs-lisp-mode-hook)
 467           (buffer-read-only))
 468       (erase-buffer)
 469       (unwind-protect
 470           (progn
 471             (emacs-lisp-mode)
 472             (let ((print-escape-newlines kfile:escape-newlines))
 473               (prin1 object (current-buffer)))
 474             (goto-char (point-min))
 475             (while (not (eobp))
 476               ;; (message "%06d" (- (point-max) (point)))
 477               (cond
 478                ((looking-at "\\s\(")
 479                 (while (looking-at "\\s(")
 480                   (forward-char 1)))
 481                ((and (looking-at "\\(quote[ \t]+\\)\\([^.)]\\)")
 482                      (> (match-beginning 1) 1)
 483                      (= ?\( (char-after (1- (match-beginning 1))))
 484                      ;; Make sure this is a two-element list.
 485                      (save-excursion
 486                        (goto-char (match-beginning 2))
 487                        (forward-sexp)
 488                        ;; (looking-at "[ \t]*\)")
 489                        ;; Avoid mucking with match-data; does this test work?
 490                        (char-equal ?\) (char-after (point)))))
 491                 ;; -1 gets the paren preceding the quote as well.
 492                 (delete-region (1- (match-beginning 1)) (match-end 1))
 493                 (insert "'")
 494                 (forward-sexp 1)
 495                 (if (looking-at "[ \t]*\)")
 496                     (delete-region (match-beginning 0) (match-end 0))
 497                   (error "Malformed quote"))
 498                 (backward-sexp 1))
 499                ((condition-case ()
 500                     (prog1 t (down-list 1))
 501                   (error nil))
 502                 (backward-char 1)
 503                 (skip-chars-backward " \t")
 504                 (delete-region
 505                  (point)
 506                  (progn (skip-chars-forward " \t") (point)))
 507                 (if (not (char-equal ?' (char-after (1- (point)))))
 508                     (insert ?\n)))
 509                ((condition-case ()
 510                     (prog1 t (up-list 1))
 511                   (error nil))
 512                 (while (looking-at "\\s)")
 513                   (forward-char 1))
 514                 (skip-chars-backward " \t")
 515                 (delete-region
 516                  (point)
 517                  (progn (skip-chars-forward " \t") (point)))
 518                 (if (not (char-equal ?' (char-after (1- (point)))))
 519                     (insert ?\n)))
 520                (t (goto-char (point-max)))))
 521             (goto-char (point-min))
 522             (indent-sexp)
 523             (buffer-string))
 524         (kill-buffer (current-buffer))))))
 525
 526 (defun kfile:pretty-print (object &optional stream)
 527   "Output the pretty-printed representation of OBJECT, any Lisp object.
 528 Quoting characters are printed when needed to make output that `read'
 529 can handle, whenever this is possible.
 530 Output stream is STREAM, or value of `standard-output' (which see)."
 531   (princ (kfile:print-to-string object) (or stream standard-output)))
 532
 533 (defun kfile:read-name (prompt existing-p)
 534   "PROMPT for and read a koutline file name.  EXISTING-P means must exist."
 535   (let ((filename))
 536     (while (not filename)
 537       (setq filename (read-file-name prompt nil nil existing-p))
 538       (if (or (null filename) (equal filename ""))
 539           (progn (ding) (setq filename nil))))
 540     filename))
 541
 542 ;;;
 543 ;;; Private variables
 544 ;;;
 545
 546 (defvar kfile:escape-newlines t
 547   "Value of print-escape-newlines used by 'kfile:print-to-string' function.")
 548
 549 (provide 'kfile)
 550
 551 ;;; kfile.el ends here