home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / utilities / utilsd / edit / !lEdit / l / text < prev    next >
Text File  |  1995-01-19  |  15KB  |  452 lines
  1. ;;;                  ***  lEdit - Lisp Editor  ***
  2. ;;;                       (c) 1995 Urs Bisang
  3. ;;;                           Version 0.1  
  4. ;;;
  5. ;;;   dieses file enthaelt high-level support routinen 
  6. ;;;         fuer das txt modul von riscoslib
  7. ;;;
  8.  
  9.  
  10. ;;; *** globale variablen ***
  11.  
  12. ;; liste aller aktiver text buffers 
  13. (define *text-bufferlist* '())
  14.  
  15. ;; default name um eine selection abzuspeichern
  16. (define *text-selection-name* "Selection")
  17.  
  18. ;; das letzte von find benutzte suchstring
  19. (define *text-previous-searchstring* "")
  20.  
  21. ;; flag das anzeigt ob find casesensitiv suchen soll
  22. (define *text-casesensitiv-find* #f)
  23.       
  24. ;; bringe den cursor an den start des text buffers
  25. (define (text-cursor-home text) (txt-setdot text 0))
  26.  
  27. ;; bringe den cursor ans ende des text buffers
  28. (define (text-cursor-end text) 
  29.   (txt-setdot text (txt-size text))) 
  30.  
  31.  
  32. ;; bewege den cursor um eine bildschirmhoehe nach unten
  33. (define (text-cursor-pagedown text)
  34.   (txt-movevertical text (txt-visiblelinecount text) 1)) 
  35.  
  36. ;; bewege den cursor um eine bildschirmhoehe nach oben
  37. (define (text-cursor-pageup text)
  38.   (txt-movevertical text (- (txt-visiblelinecount text)) 1))
  39.  
  40. ;; loesche n zeichen an der stelle i im textbuffer
  41. (define (text-deleteat text i n)
  42.   ;; falls der dot nach der selection ist, adjust dot. 
  43.   ;; falls der dot innerhalb der selection ist,
  44.   ;; setze dot an den anfang der selection   
  45.   (if (> (txt-dot text) i)
  46.       (if (< (txt-dot text) (+ i n))
  47.           (txt-setdot text i)
  48.           (txt-movedot text (- n))))
  49.   (let ((old-dot (txt-dot text)))
  50.     (txt-setdot text i)
  51.     (txt-delete text n)
  52.     (txt-setdot text old-dot)))
  53.  
  54.  
  55. ;; loesche selektierten text aus dem textbuffer
  56. (define (text-delete-selection)
  57.   (if (txtscrap-selectowner)
  58.       (let ((text  (txtscrap-selectowner))
  59.             (start (txt-selectstart text))
  60.             (end   (txt-selectend text)))   
  61.         (text-deleteat text start (- end start))
  62.         (text-clear-selection))))
  63.  
  64.  
  65. ;; loesche eine selektion   
  66. (define (text-clear-selection)
  67.   (if (txtscrap-selectowner)
  68.       (txtscrap-setselect (txtscrap-selectowner) 0 0)))                   
  69.  
  70.  
  71. ;; kopiere eine selection
  72. (define (text-copy-selection text1)
  73.   (if (txtscrap-selectowner)
  74.       (let ((text2  (txtscrap-selectowner))
  75.             (selection (txt-getselection text2)))
  76.         (txt-insertstring* text1 selection))))
  77.  
  78.  
  79. ;; verschiebe eine selection
  80. (define (text-move-selection text1)
  81.   (if (txtscrap-selectowner)
  82.       (let ((text2  (txtscrap-selectowner))
  83.             (n (- (txt-selectend text2)
  84.                   (txt-selectstart text2)))
  85.             (selection (txt-getselection text2)))
  86.         (text-delete-selection)
  87.         (txt-insertstring text1 selection)
  88.         (txtscrap-setselect text1 
  89.                             (txt-dot text1)
  90.                             (+ (txt-dot text1) n))
  91.         (txt-movedot text1 n))))
  92.  
  93.  
  94. ;; ist ein text buffer veraendert seit der letzten speicherung ? 
  95. (define (text-buffer-updated? text)
  96.   (= (bit-and (txt-charoptions text) 4) 4))
  97.  
  98.    
  99. ;; zeige aenderungen im text buffer nicht sofort an
  100. (define (text-dont-update text)
  101.   (txt-setcharoptions text 1 0))
  102.  
  103.  
  104. ;; zeige aenderungen im text buffer sofort an
  105. (define (text-update text)
  106.   (txt-setcharoptions text 1 1))
  107.  
  108.  
  109. ;; update den titel eines editor windows
  110. (define (text-update-title text)
  111.   (txt-settitle text
  112.     (string-concat 
  113.       (if (getp text 'filename)
  114.           (getp text 'filename)
  115.           *lisp-untitled-name*)
  116.       (if (text-buffer-updated? text)
  117.           " *" 
  118.           "")
  119.       (if (> (txtwin-number text) 1) 
  120.           (string-concat " " (txtwin-number text)) 
  121.           "")
  122.       " (" (getp text 'modename) ")")))
  123.  
  124.  
  125. ;; erzeuge einen neuen view eines schon bestehenden windows
  126. (define (text-new-view text)
  127.   (let ((text1 (gensym)))
  128.    (set-eval! text1 text)
  129.    (txtwin-new text)      
  130.    ;; bug in riscos lib???
  131.    ;; window title und menu handler muessen hier neu gesetzt werden
  132.    ;; damit es funktioniert !!       
  133.    (text-update-title text)
  134.    (event-attachmenumaker (txt-syshandle text)         
  135.                            lisp-ledit-menu-maker&handler
  136.                            text1)))
  137.   
  138.  
  139. ;; schliesse ein fenster eines text buffers und speichere 
  140. ;; den buffer (falls noetig) wenn das letzte fenster des 
  141. ;; buffers geschlossen wird
  142. (define (text-close-window text)
  143.   (if (> (txtwin-number text) 1)
  144.       (begin (txtwin-dispose text)
  145.              (text-update-title text))
  146.       (text-remove-buffer text)))
  147.                     
  148.  
  149. ;; entferne einen buffer und schliesse alle zum buffer gehoerenden
  150. ;; fenster. frage ob der buffer gespeichert werden soll, falls er
  151. ;; veraendert wurde
  152. (define (text-remove-buffer text)
  153.   (if (text-buffer-updated? text)
  154.       (if (text-query-save text)
  155.           (text-kill-buffer text))
  156.       (text-kill-buffer text)))
  157.  
  158.                                   
  159. ;; fragt mit einer dialogbox ob ein buffer gesaved werden soll
  160. ;; und speichert den buffer falls es zutrifft
  161. (define (text-query-save text)               
  162.   (let ((field (dbox-popup "close" "This file has been modified"))) 
  163.     (cond
  164.       ((= field 0) (text-save-buffer text))        ; save
  165.       ((= field 2) #t)                             ; discard
  166.       ((= field 3) #f)                             ; cancel
  167.       (else #f))))
  168.  
  169.  
  170. ;; entfernt einen buffer aus dem speicher und der buffer-liste
  171. (define (text-kill-buffer text)
  172.   (set! *text-bufferlist* (list-remove *text-bufferlist* text))
  173.   ;; bug in riscoslib? text selection wird nicht geloescht,
  174.   ;; wenn buffer entfernt wird !!! muss explizit geloescht werden!
  175.   (if (equal? text (txtscrap-selectowner))
  176.       (text-clear-selection))
  177.   (txt-dispose text))
  178.  
  179. ;; gib die anzahl modifizierter text buffer zurueck oder #f
  180. (define (text-modified-buffers)
  181.    (let ((n 0) (l *text-bufferlist*))
  182.      (while l
  183.        (if (text-buffer-updated? (car l))
  184.            (inc! n)) 
  185.        (set! l (cdr l)))
  186.      (if (= n 0) #f n)))
  187.  
  188.  
  189. ;; speichere einen text buffer
  190. (define (text-save-buffer text)
  191.   (if (getp text 'filename)
  192.       (text-save text)
  193.       (text-saveas text)))
  194.       
  195.  
  196. ;; speichere text buffer mittels dragging
  197. (define (text-saveas text)
  198.    (let ((filename (getp text 'filename)))
  199.      (cond (filename (txt-saveas text filename 0 (txt-size text) #t))
  200.            (else (set! filename 
  201.                    (txt-saveas text (getp text 'defaultname)
  202.                                     0 (txt-size text) #t))
  203.                  (cond (filename (setp! text 'filename filename)
  204.                                  (text-update-title text)
  205.                                  filename)
  206.                        (else #f))))))
  207.  
  208.  
  209. ;; speichere current selection mittels dragging
  210. (define (text-save-selection text1)
  211.   (let ((text (txtscrap-selectowner)))
  212.     (if text
  213.         (txt-saveas text                  
  214.                     *text-selection-name*
  215.                     (txt-selectstart text) 
  216.                     (txt-selectend text) 
  217.                     #t))))
  218.  
  219. ;; printe current selection
  220. (define (text-print-selection text1)
  221.   (let ((text (txtscrap-selectowner)))
  222.     (if text
  223.         (if (not (txt-print text 
  224.                             (txt-selectstart text)
  225.                             (txt-selectend text)
  226.                             #t))
  227.             (werr 0 "can't print - printer application not found"))))) 
  228.            
  229.  
  230. ;; speichere text buffer bei schon bekanntem namen 
  231. (define (text-save text)
  232.   (let ((filename (getp text 'filename)))
  233.     (if filename
  234.         (begin
  235.           (txt-save text filename 0 (txt-size text) #t)
  236.           (text-update-title text) 
  237.           #t)
  238.         #f)))
  239.  
  240.  
  241. ;; printe den inhalt des text buffers
  242. (define (text-print text)
  243.   (if (not (txt-print text 0 (txt-size text) #t))
  244.       (werr 0 "can't print - printer application not found")))
  245.  
  246.  
  247. ;; fuege ein in ein editor window gedraggtes file an der cursor 
  248. ;; position ein
  249. (define (text-insert-dragged-file text)
  250.   (let ((filename (car (xferrecv-checkinsert))))
  251.     (cond ((txt-load text filename (txt-dot text) #t)
  252.            (txt-setcharoptions text 4 4)   ; text is updated
  253.            (text-update-title text)))
  254.     (xferrecv-insertfileok)))   
  255.  
  256.  
  257. ;; lade ein in auf das baricon gedraggtes file und zeige
  258. ;