src/TeXmacs/progs/texmacs/texmacs/tm-files.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : files.scm
   5 ;; DESCRIPTION : file handling
   6 ;; COPYRIGHT   : (C) 2001  Joris van der Hoeven
   7 ;;
   8 ;; This software falls under the GNU general public license and comes WITHOUT
   9 ;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
  10 ;; If you don't have this file, write to the Free Software Foundation, Inc.,
  11 ;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  12 ;;
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14
  15 (texmacs-module (texmacs texmacs tm-files)
  16   (:use (texmacs texmacs tm-server) (texmacs texmacs tm-print)))
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 ;; Activation of color highlighting
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21
  22 (define (suffix->programming-language s)
  23   (cond ((== s "scm") "scheme")
  24         ((in? s '("cpp" "hpp" "cc" "hh")) "cpp")
  25         ((in? s '("mmx" "mmh")) "mathemagix")
  26         (else #f)))
  27
  28 (define (textual-tree? t)
  29   (or (atomic-tree? t)
  30       (and (== (tree-label t) 'document)
  31            (list-and (map textual-tree? (tree-children t))))))
  32
  33 (define (activate-highlighting)
  34   (and-let* ((suffix   (url-suffix (get-name-buffer)))
  35              (prog-lan (suffix->programming-language suffix)))
  36     (when (textual-tree? (buffer-tree))
  37       (init-env "prog-language" prog-lan)
  38       (init-env "mode" "prog"))))
  39
  40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41 ;; Saving
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43
  44 (tm-define current-save-target (url-none))
  45
  46 (define (secure-save-buffer file fm)
  47   (dialogue
  48     (when (or (not (url-exists? file))
  49               (dialogue-confirm?
  50                "File already exists. Overwrite existing file?" #f))
  51       (texmacs-save-buffer file fm)
  52       (activate-highlighting))))
  53
  54 (tm-define (save-buffer . l)
  55   (if (and (pair? l) (url? (car l))) (set! current-save-target (car l)))
  56   (cond ((= (length l) 0) (save-buffer (get-name-buffer)))
  57         ((url-scratch? (car l)) (interactive save-buffer))
  58         ((= (length l) 1) (texmacs-save-buffer (car l) "generic"))
  59         (else (secure-save-buffer (car l) (cadr l)))))
  60
  61 (tm-define (export-buffer to)
  62   ;; Temporary fix for saving to postscript or pdf
  63   (if (string? to) (set! to (url-relative (get-name-buffer) to)))
  64   (if (url? to) (set! current-save-target to))
  65   (if (in? (url-suffix to) '("ps" "pdf"))
  66       (print-to-file to)
  67       (texmacs-save-buffer to "generic")))
  68
  69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70 ;; Loading
  71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72
  73 (define (load-buffer-sub file fm where)
  74   (dialogue
  75     (if (and (!= fm "help")
  76              (not (url-rooted-web? file))
  77              (url-exists? file)
  78              (url-exists? (url-glue file "~"))
  79              (url-newer? (url-glue file "~") file)
  80              (dialogue-confirm? "Load more recent autosave file?" #t))
  81         (texmacs-load-buffer (url-glue file "~") fm where #t)
  82         (texmacs-load-buffer file fm where #f))
  83     (activate-highlighting)))
  84
  85 (tm-define (load-buffer . l)
  86   (with file (url-append "$TEXMACS_FILE_PATH" (car l))
  87     (cond ((= (length l) 1)
  88            (load-buffer-sub file "generic" 0))
  89           ((and (= (length l) 2) (string? (cadr l)))
  90            (load-buffer-sub file (cadr l) 0))
  91           ((and (= (length l) 2) (integer? (cadr l)))
  92            (load-buffer-sub file "generic" (cadr l)))
  93           (else (load-buffer-sub file (cadr l) (caddr l))))))
  94
  95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96 ;; Autosave
  97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98
  99 (tm-define (delayed-auto-save)
 100   (let* ((pref (get-preference "autosave"))
 101          (len (if (and (string? pref) (integer? (string->number pref)))
 102                   (* (string->number pref) 1000) 120000)))
 103     (if (> len 0)
 104         (delayed
 105           (:pause len)
 106           (auto-save)))))
 107
 108 (define (notify-autosave var val)
 109   (if (has-view?) ; delayed-autosave would crash at initialization time
 110       (delayed-auto-save)))
 111
 112 (define-preferences
 113   ("autosave" "120" notify-autosave))
 114
 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 116 ;; Miscellaneous
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118
 119 (tm-define (propose-name-buffer)
 120   (with name (url->string (get-name-buffer))
 121     (cond ((not (url-scratch? name)) name)
 122           ((os-win32?) "")
 123           (else (string-append (var-eval-system "pwd") "/")))))
 124
 125 (tm-property (load-buffer name)
 126   (:argument name smart-file "File name")
 127   (:default  name (propose-name-buffer)))
 128
 129 (tm-property (save-buffer name)
 130   (:argument name texmacs-file "Save as")
 131   (:default  name (propose-name-buffer)))
 132
 133 (tm-property (choose-file fun text type)
 134   (:interactive #t))
 135
 136 (tm-define (buffer-loader fm) (lambda (s) (load-buffer s fm)))
 137 (tm-define (buffer-saver fm) (lambda (s) (save-buffer s fm)))
 138 (tm-define (load-in-new-window s) (load-buffer s 1))
 139 (tm-define (load-browse-buffer s)
 140   (if (help-buffer?) (load-buffer s "help") (load-buffer s)))