#lang scheme/base (require scheme/class (for-syntax scheme/base) scheme/file racket/port "../syntax.ss" "private.ss" racket/snip racket/snip/private/private racket/snip/private/style racket/snip/private/snip-flags racket/snip/private/prefs "editor-admin.ss" "stream.ss" "undo.ss" "keymap.ss" "editor-data.rkt" (only-in "cycle.ss" printer-dc% text% pasteboard% editor-snip% editor-snip-editor-admin% editor-get-file editor-put-file) "wx.ss") (provide editor% editor<%> add-editor-keymap-functions ALLOW-X-STYLE-SELECTION? copy-style-list set-common-copy-region-data! cons-common-copy-buffer! cons-common-copy-buffer2! editor-set-x-selection-mode editor-x-selection-allowed editor-x-selection-mode? editor-x-selection-owner detect-wxme-file read-editor-version read-editor-global-header read-editor-global-footer write-editor-version write-editor-global-header write-editor-global-footer write-snips-to-file get-default-print-size) ;; ---------------------------------------- (define RIDICULOUS-SIZE 2000) (define ALLOW-X-STYLE-SELECTION? (eq? 'unix (system-type))) (defclass offscreen% object% (define bitmap #f) (define dc (make-object bitmap-dc%)) (define bm-width 0) (define bm-height 0) (define in-use? #f) (define last-used #f) (define/public (is-in-use?) in-use?) (define/public (set-in-use v) (set! in-use? (and v #t))) (define/public (get-bitmap) bitmap) (define/public (get-dc) dc) (define/public (get-last-used) last-used) (define/public (set-last-used v) (set! last-used v)) (define/public (ready-offscreen width height) (if (or #t ; disable on all platforms (width . > . RIDICULOUS-SIZE) (height . > . RIDICULOUS-SIZE) (eq? (system-type) 'macosx)) #f (if (and (not in-use?) (or (height . > . bm-height) (width . > . bm-width))) (let ([oldbm bitmap]) (set! bm-height (max (add1 (->long height)) bm-height)) (set! bm-width (max (add1 (->long width)) bm-width)) (set! bitmap (make-object bitmap% bm-width bm-height)) (send dc set-bitmap #f) (when (send bitmap ok?) (send dc set-bitmap bitmap)) #t) #f))) (super-new)) (define the-offscreen (new offscreen%)) ;; ---------------------------------------- ;; 8.5" x 11" paper, 0.5" margin; usually not used (define PAGE-WIDTH 612) (define PAGE-HEIGHT 792) (define (get-printer-orientation) (send (current-ps-setup) get-orientation)) (define (get-default-print-size w h) (set-box! w PAGE-WIDTH) (set-box! h PAGE-HEIGHT) (when (eq? (get-printer-orientation) 'landscape) (let ([tmp (unbox h)]) (set-box! h (unbox w)) (set-box! w tmp)))) ;; ---------------------------------------- (define emacs-style-undo? (and (get-preference* 'GRacket:emacs-undo) #t)) (define (max-undo-value? v) (or (exact-nonnegative-integer? v) (eq? v 'forever))) (define global-lock (make-semaphore 1)) (defclass editor% object% (field [s-offscreen the-offscreen] [s-admin #f] [s-keymap (new keymap%)] [s-own-caret? #f] [s-temp-filename? #f] [s-user-locked? #f] [s-modified? #f] [s-noundomode 0]) (def/public (is-modified?) s-modified?) (define undomode? #f) (define redomode? #f) (define interceptmode? #f) (define loadoverwritesstyles? #t) (field [s-custom-cursor-overrides? #f] [s-need-on-display-size? #f]) (define paste-text-only? #f) (define num-parts-modified 0) (field [s-caret-snip #f] [s-style-list (new style-list%)]) (define/public (get-focus-snip) s-caret-snip) (define/public (get-s-style-list) s-style-list) (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) (define notify-id (send s-style-list notify-on-change (lambda (which) (style-has-changed which)))) (field [s-filename #f]) ; last loaded file (define max-undos 0) (define changes #()) (define changes-start 0) (define changes-end 0) (define changes-size 0) (define redochanges #()) (define redochanges-start 0) (define redochanges-end 0) (define redochanges-size 0) (define savedchanges #f) ;; for emacs-style undo (define intercepted null) (field [s-custom-cursor #f] [s-inactive-caret-threshold 'show-inactive-caret]) (define printing #f) (define/public (get-printing) printing) (define num-extra-headers 0) (define seq-lock #f) (super-new) (define/public (~) (send s-style-list forget-notification notify-id) (clear-undos)) (define/public (is-printing?) (and printing #t)) ;; ---------------------------------------- (def/public (blink-caret) (void)) (def/public (size-cache-invalid) (void)) (def/public (locked-for-read?) #f) (def/public (locked-for-write?) #f) (def/public (locked-for-flow?) #f) (def/public (resized) (void)) (def/public (recounted) (void)) (define/public (invalidate-bitmap-cache) (void)) (def/public (needs-update) (void)) (def/public (release-snip) (void)) (def/public (scroll-line-location) (void)) (def/public (num-scroll-lines) (void)) (def/public (find-scroll-line) (void)) ;; ---------------------------------------- (define/public (on-event event) (void)) (define/public (on-char event) (void)) (def/public (on-local-event [mouse-event% event]) (unless (and s-keymap (or (send s-keymap handle-mouse-event this event) (begin (when (not (send event moving?)) (send s-keymap break-sequence)) #f))) (on-default-event event))) (def/public (on-local-char [key-event% event]) (unless (and s-keymap (or (send s-keymap handle-key-event this event) (begin (send s-keymap break-sequence) #f))) (on-default-char event))) (define/public (on-default-event event) (void)) (define/public (on-default-char event) (void)) (def/public (on-focus [any? on?]) (void)) ;; ---------------------------------------- (def/public (set-admin [(make-or-false editor-admin%) administrator]) (setting-admin administrator) (set! s-admin administrator) (when (not s-admin) (set! s-own-caret? #f)) (when s-admin (init-new-admin))) (def/public (setting-admin [(make-or-false editor-admin%) a]) (void)) (def/public (init-new-admin) (void)) (def/public (get-admin) s-admin) ;; ---------------------------------------- (def/public (own-caret [any? ownit?]) (void)) (def/public (do-own-caret [any? ownit?]) (let ([ownint? (and ownit? #t)]) (let ([refresh? (and (not s-caret-snip) (not (eq? s-own-caret? ownit?)))]) (set! s-own-caret? ownit?) (when s-caret-snip (send s-caret-snip own-caret ownit?)) (when (and s-keymap (not ownint?) refresh?) (send s-keymap break-sequence)) (when ALLOW-X-STYLE-SELECTION? (cond [(and ownit? (not s-caret-snip)) (set! editor-x-selection-allowed this)] [(eq? editor-x-selection-allowed this) (set! editor-x-selection-allowed #f)])) (when s-admin (send s-admin update-cursor)) refresh?))) (def/public (get-dc) ;; this can be called by snips to get a DC appropriate for ;; sizing text, etc., outside of draws. it isn't the destination ;; for draws, though (if s-admin (send s-admin get-dc #f #f) #f)) (def/public (get-view-size [(make-or-false box?) w][(make-or-false box?) h]) (if s-admin (send s-admin get-view #f #f w h) (begin (when w (set-box! w 0.0)) (when h (set-box! h 0.0))))) (define/public (get-snip-location snip x y) (when x (set-box! x 0.0)) (when y (set-box! y 0.0)) #t) (def/public (do-set-caret-owner [(make-or-false snip%) snip] [symbol? dist]) (let ([same? (eq? snip s-caret-snip)]) (if (and same? (or (not s-admin) (eq? dist 'immediate))) #f (begin (when same? (send s-admin grab-caret dist)) (let ([vis-caret? s-own-caret?]) (cond [(or (not snip) (not (has-flag? (snip->flags snip) HANDLES-EVENTS))) (let ([old-caret s-caret-snip] [refresh? #f]) (set! s-caret-snip #f) (when old-caret (send old-caret own-caret #f) (when vis-caret? (set! refresh? #t))) (when ALLOW-X-STYLE-SELECTION? (set! editor-x-selection-allowed this)) (when s-admin (send s-admin update-cursor)) refresh?)] [(not (get-snip-location snip #f #f)) #f] [else (let ([had-caret? (and s-own-caret? (not s-caret-snip))] [old-caret s-caret-snip] [refresh? #f]) (set! s-caret-snip snip) (begin-edit-sequence) (cond [old-caret (send old-caret own-caret #f)] [vis-caret? (set! refresh? #t)]) (send snip own-caret s-own-caret?) (end-edit-sequence) (when (and s-admin (not (eq? dist 'immediate))) (send s-admin grab-caret dist)) (when s-admin (send s-admin update-cursor)) refresh?)])))))) (define/private (convert-coords admin x y to-local?) (let-values ([(lx ly) (if admin (if (admin . is-a? . editor-snip-editor-admin%) (let* ([snip (send admin get-snip)] [sa (send snip get-admin)]) (if sa (let ([mbuf (send sa get-editor)]) (if mbuf (let-boxes ([bx 0.0][by 0.0] [lx 0.0][ly 0.0] [l 0.0][t 0.0][r 0.0][b 0.0]) (begin (send mbuf local-to-global bx by) (send mbuf get-snip-location snip lx ly #f) (send snip get-margin l t r b)) (values (+ lx bx l) (+ ly by t))) (values 0.0 0.0))) (values 0.0 0.0))) (let-boxes ([lx 0.0][ly 0.0]) (send admin get-dc lx ly) (values (- lx) (- ly)))) (values 0.0 0.0))]) (when x (set-box! x (+ (unbox x) (if to-local? (- lx) lx)))) (when y (set-box! y (+ (unbox y) (if to-local? (- ly) ly)))))) (def/public (editor-location-to-dc-location [real? x] [real? y]) (let-boxes ([x x] [y y]) (local-to-global x y) (values x y))) (def/public (dc-location-to-editor-location [real? x] [real? y]) (let-boxes ([x x] [y y]) (global-to-local x y) (values x y))) (def/public (global-to-local [maybe-box? x] [maybe-box? y]) (convert-coords s-admin x y #t)) (def/public (local-to-global [maybe-box? x] [maybe-box? y]) (convert-coords s-admin x y #f)) (def/public (set-cursor [(make-or-false cursor%) c] [any? [override? #t]]) (set! s-custom-cursor c) (set! s-custom-cursor-overrides? override?) (when s-admin (send s-admin update-cursor))) (def/public (adjust-cursor [mouse-event% event]) (void)) ;; ---------------------------------------- (def/public (set-keymap [(make-or-false keymap%) [k #f]]) (set! s-keymap k)) (def/public (get-keymap) s-keymap) (def/public (get-style-list) s-style-list) (def/public (set-style-list [style-list% new-list]) (send s-style-list forget-notification notify-id) (set! notify-id (send new-list notify-on-change (lambda (which) (style-has-changed which)))) (set! s-style-list new-list) ;; create "Standard" if it's not there: (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) (void)) (define/public (style-has-changed which) (void)) (def/public (default-style-name) "Standard") (def/public (get-default-style) (send s-style-list find-named-style (default-style-name))) ;; ---------------------------------------- (define/public (set-max-width w) (void)) (define/public (set-min-width v) (void)) (define/public (get-max-width) 0.0) (define/public (get-min-width) 0.0) (define/public (set-min-height w) (void)) (define/public (set-max-height w) (void)) (define/public (get-min-height) 0.0) (define/public (get-max-height) 0.0) (define/public (find-first-snip) #f) (define/public (get-extent) (void)) (define/public (get-descent) (void)) (define/public (get-space) (void)) (define/public (get-flattened-text) (void)) ;; ---------------------------------------- (define/public (clear) (void)) (define/public (cut ? time) (void)) (define/public (copy ? time) (void)) (define/public (paste time) (void)) (define/public (paste-x-selection time) (void)) (define/public (kill time) (void)) (define/public (select-all) (void)) (define/public (insert snip) (void)) (define/public (insert-paste-snip snip) (void)) (define/public (insert-paste-string str) (void)) (define/public (do-read-insert snip) (void)) (define/public (set-caret-owner snip focus) (void)) (define/public (read-from-file mf) #f) (def/public (do-edit-operation [symbol? op] [any? [recursive? #t]] [exact-integer? [time 0]]) (if (and recursive? s-caret-snip) (send s-caret-snip do-edit-operation op #t time) (case op [(undo) (undo)] [(redo) (redo)] [(clear) (clear)] [(cut) (cut #f time)] [(copy) (copy #f time)] [(paste) (paste time)] [(kill) (kill time)] [(insert-text-box) (insert-box 'text)] [(insert-pasteboard-box) (insert-box 'pasteboard)] [(insert-image) (insert-image)] [(select-all) (select-all)]))) (def/public (can-do-edit-operation? [symbol? op] [any? [recursive? #t]]) (if (and recursive? s-caret-snip) (send s-caret-snip can-do-edit-operation? op #t) (cond [(and (is-locked?) (not (or (eq? op 'copy) (eq? op 'select-all)))) #f] [(and (eq? op 'undo) (= changes-start changes-end)) #f] [(and (eq? op 'redo) (= redochanges-start redochanges-end)) #f] [else (really-can-edit? op)]))) (define/public (really-can-edit?) #f) (def/public (insert-box [symbol? [type 'text]]) (let ([snip (on-new-box type)]) (when snip (let ([sname (default-style-name)]) (begin-edit-sequence) (send snip set-s-style (or (send s-style-list find-named-style sname) (send s-style-list basic-style))) (insert snip) (set-caret-owner snip) (end-edit-sequence))))) (def/public (on-new-box [symbol? type]) (let* ([media (if (eq? type 'text) (new text%) (new pasteboard%))] [snip (make-object editor-snip% media)]) (send media set-keymap s-keymap) (send media set-style-list s-style-list) snip)) (def/public (insert-image [(make-or-false path-string?) [filename #f]] [image-type? [type 'unknown/alpha]] [any? [relative? #f]] [any? [inline-img? #t]]) (let ([filename (or filename (get-file #f))]) (when filename (let ([snip (on-new-image-snip filename type (and relative? #t) (and inline-img? #t))]) (insert snip))))) (def/public (on-new-image-snip [path-string? filename] [image-type? type] [any? relative?] [any? inline-img?]) (make-object image-snip% filename type relative? inline-img?)) ;; ---------------------------------------- (def/public (get-snip-data [snip% s]) #f) (def/public (set-snip-data [snip% s] [editor-data% v]) (void)) ;; ---------------------------------------- (def/public (read-header-from-file [editor-stream-in% f] [string? header-name]) (error 'read-header-from-file "unknown header data: ~s" header-name)) (def/public (read-footer-from-file [editor-stream-in% f] [string? header-name]) (error 'read-header-from-file "unknown footer data: ~s" header-name)) (def/public (write-headers-to-file [editor-stream-out% f]) #t) (def/public (write-footers-to-file [editor-stream-out% f]) #t) (def/public (begin-write-header-footer-to-file [editor-stream-out% f] [string? header-name] [box? data-buffer]) (set-box! data-buffer (send f tell)) (send f put-fixed 0) (send f put-unterminated (string->bytes/utf-8 header-name)) #t) (def/public (end-write-header-footer-to-file [editor-stream-out% f] [exact-integer? data]) (let ([end (send f tell)]) (send f jump-to data) (send f put-fixed 0) (let ([pos (send f tell)]) (send f jump-to data) (send f put-fixed (- end pos)) (send f jump-to end) (set! num-extra-headers (add1 num-extra-headers)) #t))) (def/public (read-headers-footers [editor-stream-in% f] [any? headers?]) (let-boxes ([num-headers 0]) (send f get-fixed num-headers) (for/fold ([ok? #t]) ([i (in-range num-headers)] #:when ok?) (let-boxes ([len 0]) (send f get-fixed len) (and (send f ok?) (if (positive? len) (let ([pos (send f tell)]) (send f set-boundary len) (let ([header-name (bytes->string/utf-8 (send f get-unterminated-bytes) #\?)]) (and (if headers? (read-header-from-file f header-name) (read-footer-from-file f header-name)) (send f ok?) (begin (send f remove-boundary) (let ([len (- len (- (send f tell) pos))]) (when (positive? len) (send f skip len)) (send f ok?)))))) #t)))))) (define/public (do-write-headers-footers f headers?) (let ([all-start (send f tell)]) (send f put-fixed 0) (set! num-extra-headers 0) (and (if headers? (write-headers-to-file f) (write-footers-to-file f)) (begin (when (positive? num-extra-headers) (let ([all-end (send f tell)]) (send f jump-to all-start) (send f put-fixed num-extra-headers) (send f jump-to all-end)) #t))))) ;; ---------------------------------------- (def/public (read-snips-from-file [editor-stream-in% f] [any? overwritestylename?]) (and (read-headers-footers f #t) (let* ([list-id (box 0)] [new-list (read-styles-from-file s-style-list f overwritestylename? list-id)]) (and new-list (begin (unless (eq? new-list s-style-list) (set-style-list new-list)) (let-boxes ([num-headers 0]) (send f get-fixed num-headers) (and ;; Read headers (for/and ([i (in-range num-headers)]) (let ([n (send f get-exact)] [len (send f get-fixed-exact)]) (and (send f ok?) (or (zero? len) (let ([sclass (send (send f get-s-scl) find-by-map-position f n)]) (and (if sclass (let ([start (send f tell)]) (send f set-boundary len) (and (send sclass read-header f) (send f ok?) (begin (send f do-set-header-flag sclass) (let ([rcount (- (send f tell) start)]) (when (rcount . < . len) (error 'read-snips-from-file "underread (caused by file corruption?)")) (send f skip (- len rcount))) (send f remove-boundary) #t))) (begin (send f skip len) #t)) (send f ok?))))))) ;; Read snips (let-boxes ([num-snips 0]) (send f get num-snips) (let ([accum? (this . is-a? . text%)]) (let ([accum (for/fold ([accum null]) ([i (in-range num-snips)] #:when accum) (let ([n (send f get-exact)]) (let ([sclass (if (n . >= . 0) (send (send f get-s-scl) find-by-map-position f n) #f)]) ; -1 => unknown (let ([len (if (or (not sclass) (not (send sclass get-s-required?))) (send f get-fixed-exact) -1)]) (and (send f ok?) (or (and (zero? len) accum) (and (if sclass (let ([start (send f tell)]) (when (len . >= . 0) (send f set-boundary len)) (let ([style-index (send f get-exact)]) (let ([snip (send sclass read f)]) (and snip (begin (when (has-flag? (snip->flags snip) OWNED) (send snip set-s-flags (remove-flag (snip->flags snip) OWNED))) (send snip set-s-style (or (send s-style-list map-index-to-style f style-index (unbox list-id)) (send s-style-list basic-style))) (let* ([zero-length? (zero? (snip->count snip))] [accum (if zero-length? ;; A 0-length snip is a bug in the input, but ;; we continue anyway to recover from bad ;; files generated by version 4.2. accum (if accum? (cons snip accum) (do-read-insert snip)))]) (and accum (let ([data (read-buffer-data f)]) (and (send f ok?) (let ([accum (if zero-length? accum (if accum? (cons (cons (car accum) data) (cdr accum)) (when data (set-snip-data snip data))))]) (and accum (begin (when (len . >= . 0) (let ([rcount (- (send f tell) start)]) (when (rcount . < . len) (error 'read-snips-from-file "underread (caused by file corruption?)")) (send f skip (- len rcount)) (send f remove-boundary))) accum)))))))))))) (begin (send f skip len) (and (send f ok?) accum))))))))))]) (and accum (begin (when accum? (let ([accum (reverse accum)]) (send this do-read-insert (map car accum)) (for ([p (in-list accum)]) (when (cdr p) (set-snip-data (car p) (cdr p)))))) (read-headers-footers f #f))))))))))))) ;; ---------------------------------------- (define/public (insert-port) (void)) (define/public (insert-file) (void)) (define/public (save-port) (void)) (define/public (load-file) (void)) (define/public (set-filename) (void)) (define/public (write-to-file) (void)) (def/public (get-filename [(make-or-false box?) [temp #f]]) (when temp (set-box! temp s-temp-filename?)) s-filename) (define/private (extract-parent) (and s-admin ((send s-admin get-s-standard) . > . 0) (let ([w (send s-admin do-get-canvas)]) (send w get-top-level)))) (define/public (do-begin-print) (void)) (define/public (print-to-dc) (void)) (define/public (do-end-print) (void)) (define/public (do-has-print-page?) (void)) (define/private (run-printout parent interactive? ; currently ignored fit-to-page? ; ignored begin-doc-proc has-page?-proc print-page-proc end-doc-proc) (let ([dc (make-object printer-dc% parent)]) (send dc start-doc "printing") (begin-doc-proc dc) (let loop ([i 1]) (when (has-page?-proc dc i) (begin (send dc start-page) (print-page-proc dc i) (send dc end-page) (loop (add1 i))))) (end-doc-proc) (send dc end-doc))) (def/public (print [bool? [interactive? #t]] [bool? [fit-to-page? #t]] [(symbol-in standard postscript pdf) [output-mode 'standard]] [any? [parent #f]] ; checked in ../editor.ss [bool? [force-page-bbox? #t]] [bool? [as-eps? #f]]) (let ([ps? (or (eq? output-mode 'postscript) (eq? output-mode 'pdf))] [parent (or parent (extract-parent))]) (cond [ps? (let* ([ps-dc% (if (eq? output-mode 'postscript) post-script-dc% pdf-dc%)] [dc (if as-eps? ;; just for size: (new ps-dc% [interactive #f] [output (open-output-nowhere)]) ;; actual target: (make-object ps-dc% interactive? parent force-page-bbox? #f))]) (when (send dc ok?) (send dc start-doc "printing buffer") (set! printing dc) (let ([data (do-begin-print dc fit-to-page?)]) (let ([new-dc (if as-eps? ;; now that we know the size, create the actual target: (let ([w (box 0)] [h (box 0)] [sx (box 0)] [sy (box 0)]) (get-extent w h) (send (current-ps-setup) get-scaling sx sy) (let ([dc (make-object ps-dc% interactive? parent force-page-bbox? #t (* (unbox w) (unbox sx)) (* (unbox h) (unbox sy)))]) (and (send dc ok?) (send dc start-doc "printing buffer") (set! printing dc) dc))) dc)]) (when new-dc (print-to-dc new-dc (if as-eps? 0 -1)) (when as-eps? (send new-dc end-doc))) (set! printing #f) (do-end-print dc data) (send dc end-doc) (invalidate-bitmap-cache 0.0 0.0 'end 'end)))))] [else (let ([data #f]) (run-printout ;; from wx parent interactive? fit-to-page? ;; begin-doc: (lambda (dc) (set! printing dc) (set! data (do-begin-print printing fit-to-page?))) ;; has page?: (lambda (dc n) (do-has-print-page? dc n)) ;; print-page: (lambda (dc n) (print-to-dc dc n)) ;; end-doc (lambda () (let ([pr printing]) (set! printing #f) (do-end-print printing data)) (invalidate-bitmap-cache 0.0 0.0 'end 'end))))]))) (def/public (undo) (when (and (not undomode?) (not redomode?)) (set! undomode? #t) (perform-undos #f) (set! undomode? #f))) (def/public (redo) (when (and (not undomode?) (not redomode?)) (set! redomode? #t) (perform-undos #t) (set! redomode? #f))) (define/private (do-clear-undos changes start end size) (let loop ([i start]) (unless (= i end) (send (vector-ref changes i) cancel) (vector-set! changes i #f) (loop (modulo (+ i 1) size))))) (define/public (add-undo-rec rec) (cond [interceptmode? (send intercepted append rec)] [undomode? (append-undo rec #t)] [(zero? s-noundomode) (when (not redomode?) (cond [emacs-style-undo? (when (not (= redochanges-start redochanges-end)) (let loop ([e redochanges-end]) (unless (= redochanges-start e) (let ([e (modulo (+ e -1 redochanges-size) redochanges-size)]) (append-undo (send (vector-ref redochanges e) inverse) #f) (loop e)))) (let loop () (unless (= redochanges-start redochanges-end) (append-undo (vector-ref redochanges redochanges-start) #f) (vector-set! redochanges redochanges-start #f) (set! redochanges-start (modulo (add1 redochanges-start) redochanges-size)))) (set! redochanges-start 0) (set! redochanges-end 0))] [else (do-clear-undos redochanges redochanges-start redochanges-end redochanges-size) (set! redochanges-start 0) (set! redochanges-end 0)])) (append-undo rec #f)] [else (send rec cancel)])) (def/public (add-undo [(make-procedure 0) proc]) (add-undo-rec (new proc-record% [proc proc]))) (define/private (append-undo rec redos?) (if (or (eq? max-undos 'forever) (positive? max-undos)) (let-values ([(start end size c) (get-undos redos?)]) (let-values ([(size c) (if (zero? size) (let ([size (min 128 (if (eq? max-undos 'forever) 128 max-undos))]) (values size (make-vector size #f))) (values size c))]) (vector-set! c end rec) (let ([end (modulo (add1 end) size)]) (let-values ([(start end size c) (if (= end start) (if (or (eq? max-undos 'forever) (size . < . max-undos) emacs-style-undo?) ;; make more room (let* ([s (min (* size 2) (if (eq? max-undos 'forever) (* size 2) max-undos))] [naya (make-vector s #f)]) (for ([j (in-range size)]) (vector-set! naya j (vector-ref c (modulo (+ start j) size)))) (values 0 size s naya)) ;; no room to grow, so drop an undo record (begin (send (vector-ref c start) cancel) (vector-set! c start #f) (values (modulo (add1 start) size) end size c))) (values start end size c))]) (put-undos-back redos? start end size c))))) (send rec cancel))) (define/private (get-undos redos?) (if redos? (values redochanges-start redochanges-end redochanges-size redochanges) (values changes-start changes-end changes-size changes))) (define/private (put-undos-back redos? start end size c) (if redos? (begin (set! redochanges-start start) (set! redochanges-end end) (set! redochanges-size size) (set! redochanges c)) (begin (set! changes-start start) (set! changes-end end) (set! changes-size size) (set! changes c)))) (def/public (begin-edit-sequence) (void)) (def/public (end-edit-sequence) (void)) (def/public (in-edit-sequence?) #f) (def/public (refresh-delayed?) #f) (def/public (locations-computed?) #f) (define/private (perform-undos redos?) (let ([id #f] [parity #f]) (let-values ([(start end size c) (get-undos redos?)]) (begin-edit-sequence) (let loop ([end end]) (unless (= start end) (let ([end (modulo (+ end -1 size) size)]) (let ([rec (vector-ref c end)]) (vector-set! c end #f) (put-undos-back redos? start end size c) (when emacs-style-undo? (set! id (send rec get-id)) (set! parity (send rec get-parity))) (when (send rec undo this) (loop end)))))) (end-edit-sequence) (when (and emacs-style-undo? (not redos?)) ;; combine all new steps into one undo record, and ;; set/generate id (let-values ([(start end size c) (get-undos #t)]) (unless (= start end) (let ([cnt (let loop ([e end][cnt 0]) (if (= start e) cnt (let ([e (modulo (+ e -1 size) size)]) (if (send (vector-ref c e) is-composite?) cnt (loop e (add1 cnt))))))]) (when (positive? cnt) (let ([cu (new composite-record% [count cnt] [id id] [parity? (not parity)])]) (for ([i (in-range cnt)]) (let ([e (modulo (+ (- end cnt) i size) size)]) (send cu add-undo i (vector-ref c e)) (vector-set! c e #f))) (let ([e (modulo (+ (- end cnt) size) size)]) (vector-set! c e cu) (set! redochanges-end (modulo (add1 e) size)))))))))))) (define/public (perform-undo-list changes) (begin-edit-sequence) (let loop ([changes changes]) (unless (null? changes) (when (send (car changes) undo this) (loop (cdr changes))))) (end-edit-sequence)) (define/public (clear-undos) (do-clear-undos changes changes-start changes-end changes-size) (set! changes-start 0) (set! changes-end 0) (do-clear-undos redochanges redochanges-start redochanges-end redochanges-size) (set! redochanges-start 0) (set! redochanges-end 0)) (def/public (set-max-undo-history [max-undo-value? v]) (unless (or undomode? redomode? (eq? v max-undos)) (when (equal? 0 v) (clear-undos) (set! changes #f) (set! redochanges #f) (set! changes-size 0) (set! redochanges-size 0)) ;; should we bother downsizing if max-undos gets smaller but stays ;; non-0? (set! max-undos v))) (def/public (get-max-undo-history) max-undos) (def/public (s-start-intercept) (set! interceptmode? #t) (set! intercepted null)) (def/public (s-end-intercept) (begin0 intercepted (set! interceptmode? #f) (set! intercepted null))) ;; ---------------------------------------- ;; see top-level functions below, at "copy ring" (define/public (copy-ring-next) (vector-set! copy-ring-buffer1 copy-ring-pos common-copy-buffer) (vector-set! copy-ring-buffer2 copy-ring-pos common-copy-buffer2) (vector-set! copy-ring-data copy-ring-pos common-copy-region-data) (vector-set! copy-ring-style copy-ring-pos copy-style-list) (set! copy-ring-pos (sub1 copy-ring-pos)) (when (copy-ring-pos . < . 0) (set! copy-ring-pos (sub1 copy-ring-max))) (set! common-copy-buffer (vector-ref copy-ring-buffer1 copy-ring-pos)) (set! common-copy-buffer2 (vector-ref copy-ring-buffer2 copy-ring-pos)) (set! common-copy-region-data (vector-ref copy-ring-data copy-ring-pos)) (set! copy-style-list (vector-ref copy-ring-style copy-ring-pos))) (define/public (begin-copy-buffer) (set! copy-depth (add1 copy-depth))) (define/public (end-copy-buffer) (set! copy-depth (sub1 copy-depth))) (define/public (free-old-copies) (when copy-style-list (if (copy-depth . > . 1) ;; delete current "ring" occupant: (begin (set! common-copy-buffer null) (set! common-copy-buffer2 null) (set! common-copy-region-data #f) (set! copy-style-list #f)) (begin (vector-set! copy-ring-buffer1 copy-ring-pos common-copy-buffer) (vector-set! copy-ring-buffer2 copy-ring-pos common-copy-buffer2) (vector-set! copy-ring-data copy-ring-pos common-copy-region-data) (vector-set! copy-ring-style copy-ring-pos copy-style-list) (when (copy-ring-max . > . copy-ring-dest) ;; no more space: delete current ring occupant: (vector-set! copy-ring-buffer1 copy-ring-dest #f) (vector-set! copy-ring-buffer2 copy-ring-dest #f) (vector-set! copy-ring-data copy-ring-dest #f)) (set! common-copy-buffer null) (set! common-copy-buffer2 null) (set! common-copy-region-data #f) (set! copy-style-list #f) (set! copy-ring-pos copy-ring-dest) (set! copy-ring-dest (add1 copy-ring-dest)) (when (copy-ring-max . < . copy-ring-dest) (set! copy-ring-max copy-ring-dest)) (when (copy-ring-dest . >= . copy-ring-size) (set! copy-ring-dest 0)))))) (define/public (install-copy-buffer time sl) (set! copy-style-list sl) (when (not (= copying-self copy-depth)) (when (or (not ALLOW-X-STYLE-SELECTION?) (not x-clipboard-hack?)) (send the-clipboard set-clipboard-client the-editor-clipboard-client time)))) (define/public (do-buffer-paste cb time local?) ;; cut and paste to ourself? (same eventspace?) (if (or local? (and (not paste-text-only?) (send cb same-clipboard-client? the-editor-clipboard-client) (send the-editor-clipboard-client same-eventspace? (current-eventspace)))) ;; local direct copy: (begin (set! copy-depth (add1 copy-depth)) (map (lambda (snip bd) (insert-paste-snip (send snip copy) bd)) (reverse common-copy-buffer) (reverse common-copy-buffer2)) (set! copy-depth (sub1 copy-depth)) (when (and common-copy-region-data (this . is-a? . text%)) (send this paste-region-data common-copy-region-data))) ;; general paste: (or (and (not paste-text-only?) (let ([str (send cb get-clipboard-data "WXME" time)]) (and str (let* ([b (make-object editor-stream-in-bytes-base% str)] [mf (make-object editor-stream-in% b)]) (and (read-editor-version mf b #t #f) (begin (when (read-editor-global-header mf) (when (send mf ok?) (when (read-from-file mf) (let ([data (read-buffer-data mf)]) (and data (this . is-a? . text%) (send this paste-region-data data)))))) (read-editor-global-footer mf) #t)))))) (and (not paste-text-only?) (let ([bm (send cb get-clipboard-bitmap time)]) (and bm (begin (insert-paste-snip (make-object image-snip% bm) #f) #t)))) (let ([str (send cb get-clipboard-string time)]) ;; no data => empty string (insert-paste-string str))))) (def/public (copy-self) (void)) (def/public (copy-self-to [editor<%> m]) ;; copy style list (send (send m get-s-style-list) copy s-style-list) ;; copy all the snips: (let ([save-buffer common-copy-buffer] [save-buffer2 common-copy-buffer2] [save-styles copy-style-list] [save-data common-copy-region-data] [save-cs copying-self]) (send m begin-edit-sequence) (set! common-copy-buffer null) (set! common-copy-buffer2 null) (set! copy-style-list #f) (set! common-copy-region-data #f) (set! copying-self (add1 copy-depth)) (cond [(this . is-a? . text%) (send this copy #t 0 0 (send this last-position))] [(this . is-a? . pasteboard%) (begin-edit-sequence) (let ([unselect (let loop ([s (send this find-first-snip)]) (if s (if (send this is-selected? s) (loop (snip->next s)) (begin (send this add-selected s) (cons s (loop (snip->next s))))) null))]) (send this copy #t 0) (for-each (lambda (s) (send this remove-selected s)) unselect)) (end-edit-sequence)]) (let ([copy-snips (reverse common-copy-buffer)] [copy-snips2 (reverse common-copy-buffer2)]) (set! common-copy-buffer save-buffer) (set! common-copy-buffer2 save-buffer2) (set! copy-style-list save-styles) (set! common-copy-region-data save-data) (set! copying-self save-cs) (when (this . is-a? . text%) (send m do-insert-snips copy-snips 0)) (for-each (lambda (s bfd) (unless (this . is-a? . text%) (send m insert s #f)) (when bfd (send m set-snip-data s bfd))) copy-snips copy-snips2) (send m size-cache-invalid) (send m set-min-width (get-min-width)) (send m set-max-width (get-max-width)) (send m set-min-height (get-min-height)) (send m set-max-height (get-max-height)) (let-boxes ([temp? (box #f)] [f (box #f)]) (set-box! f (get-filename temp?)) (send m set-filename f temp?)) (send m set-max-undo-history (get-max-undo-history)) (send m set-keymap (get-keymap)) (send m set-inactive-caret-threshold (get-inactive-caret-threshold)) (send m set-load-overwrites-styles (get-load-overwrites-styles)) (send m end-edit-sequence)))) ;; ---------------------------------------- (define/public (own-x-selection) (void)) (define/public (do-own-x-selection on? force?) (if on? (if (and (not force?) (not (eq? editor-x-selection-allowed this))) #f (begin (when editor-x-selection-owner (send editor-x-selection-owner own-x-selection #f #t #f) (set! editor-x-selection-owner #f)) (set! x-selection-copied? #f) (send the-x-selection-clipboard set-clipboard-client the-editor-x-clipboard-client 0) (set! editor-x-selection-owner this) #t)) (begin (when (eq? this editor-x-selection-owner) (set! editor-x-selection-owner #f) (when (and (not x-selection-copied?) (send the-x-selection-clipboard same-clipboard-client? the-editor-x-clipboard-client)) (send the-x-selection-clipboard set-clipboard-string "" 0))) #t))) (define/public (copy-out-x-selection) (when (eq? this editor-x-selection-owner) (copy-into-selection) (set! x-selection-copied? #t))) (def/public (get-paste-text-only) paste-text-only?) (def/public (set-paste-text-only [any? pto?]) (set! paste-text-only? (and pto? #t))) ;; ---------------------------------------- (def/public (lock [any? lock?]) (set! s-user-locked? (and lock? #t))) (def/public (is-locked?) s-user-locked?) (def/public (modified?) s-modified?) (def/public (set-modified [any? mod?]) (let ([mod? (and mod? #t)]) (unless (eq? mod? s-modified?) (set! s-modified? mod?) (when mod? (set! num-parts-modified 1)) (when (and (not mod?) (not undomode?)) ;; get rid of undos that reset the modification state (set! num-parts-modified 0) (let loop ([i changes-end]) (unless (= i changes-start) (let ([i (modulo (+ i -1 changes-size) changes-size)]) (send (vector-ref changes i) drop-set-unmodified) (loop i)))) (let loop ([i redochanges-end]) (unless (= i redochanges-start) (let ([i (modulo (+ i -1 redochanges-size) redochanges-size)]) (send (vector-ref redochanges i) drop-set-unmodified) (loop i))))) (when s-admin (send s-admin modified s-modified?)) (when (and (not mod?) (not undomode?)) ;; tell all snips that they should now consider themselves unmodified: (let loop ([snip (find-first-snip)]) (when snip (send snip set-unmodified) (loop (snip->next snip)))))))) (def/public (on-snip-modified [snip% s] [any? mod?]) (if (not mod?) (when (= num-parts-modified 1) (set! num-parts-modified 0) (when s-modified? (set-modified #f))) (if s-modified? (set! num-parts-modified (add1 num-parts-modified)) (set-modified #t)))) (def/public (get-inactive-caret-threshold) s-inactive-caret-threshold) (def/public (set-inactive-caret-threshold [(symbol-in no-caret show-inactive-caret show-caret) v]) (set! s-inactive-caret-threshold v)) (define/public (scroll-editor-to localx localy w h refresh? bias) (if s-admin (send s-admin scroll-to localx localy w h refresh? bias) #f)) (def/public (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] [caret-status? show-caret] [(make-or-false color%) bg-color]) (void)) (def/public (on-paint [any? pre?] [dc<%> dc] [real? l] [real? t] [real? r] [real? b] [real? dx] [real? dy] [caret-status? show-caret]) (void)) (def/public (can-save-file? [path-string? filename] [symbol? format]) #t) (def/public (on-save-file [path-string? filename] [symbol? format]) (void)) (def/public (after-save-file [any? ok?]) (void)) (def/public (can-load-file? [path-string? filename] [symbol? format]) #t) (def/public (on-load-file [path-string? filename] [symbol? format]) (void)) (def/public (after-load-file [any? ok?]) (void)) (def/public (on-edit-sequence) (void)) (def/public (after-edit-sequence) (void)) (def/public (on-display-size) (void)) (def/public (on-change) (void)) (def/public (on-display-size-when-ready) (cond [(in-edit-sequence?) (set! s-need-on-display-size? #t)] [(or (not seq-lock) (semaphore-try-wait? seq-lock)) (when seq-lock (semaphore-post seq-lock)) (on-display-size)] [else (set! s-need-on-display-size? #t)])) (def/public (begin-sequence-lock) (call-with-semaphore global-lock (lambda () (unless seq-lock (set! seq-lock (make-semaphore 1))))) ;; "Try" really should succeed, because multiple refreshes are ;; prevented through other flags. Still, we don't want to block if ;; someone previously escaped from a repaint. (void (semaphore-try-wait? seq-lock))) (def/public (end-sequence-lock) (semaphore-post seq-lock)) (def/public (wait-sequence-lock) (when seq-lock (sync seq-lock) (semaphore-post seq-lock))) (def/public (get-file [(make-or-false path-string?) path]) (editor-get-file "choose a file" (extract-parent) #f path)) (def/public (put-file [(make-or-false path-string?) dir] [(make-or-false path-string?) suggested-name]) (editor-put-file "save file as" (extract-parent) dir suggested-name)) (def/public (set-load-overwrites-styles [any? b?]) (set! loadoverwritesstyles? (and b? #t))) (def/public (get-load-overwrites-styles) loadoverwritesstyles?)) (define editor<%> (class->interface editor%)) ;; ------------------------------------------------------------ (define/top (add-editor-keymap-functions [keymap% tab]) (let ([add (lambda (n f) (send tab add-function n f))]) (add "copy-clipboard" (lambda (e event) (send e copy #f (send event get-time-stamp)))) (add "copy-append-clipboard" (lambda (e event) (send e copy #t (send event get-time-stamp)))) (add "paste-clipboard" (lambda (e event) (send e paste (send event get-time-stamp)))) (add "paste-x-selection" (lambda (e event) (send e paste-x-selection (send event get-time-stamp)))) (add "cut-clipboard" (lambda (e event) (send e cut #f (send event get-time-stamp)))) (add "cut-append-clipboard" (lambda (e event) (send e cut #t (send event get-time-stamp)))) (add "delete-to-end-of-line" (lambda (e event) (send e kill (send event get-time-stamp)))) (add "undo" (lambda (e event) (send e undo))) (add "redo" (lambda (e event) (send e redo))) (add "delete-selection" (lambda (e event) (send e clear))) (add "clear-selection" (lambda (e event) (send e clear))) (add "select-all" (lambda (e event) (send e select-all))))) ;; ------------------------------------------------------------ (define (write-buffer-data f data) (let loop ([data data]) (if data (let ([mp (send f do-map-position (send data get-s-dataclass))]) (send f put mp) (let ([req? (send (send data get-s-dataclass) get-s-required?)]) (let-values ([(data-start data-pos) (if req? (values #f #f) (values (send f tell) (begin (send f put-fixed 0) (send f tell))))]) (if (not (send data write f)) #f (begin (unless req? (let ([data-end (send f tell)]) (send f jump-to data-start) (send f put-fixed (- data-end data-pos)) (send f jump-to data-end))) (loop (send data get-s-next))))))) (begin (send f put 0) #t)))) (define (write-snips-to-file f style-list snip-list start-snip end-snip extra-data buffer) (and (write-styles-to-file style-list f) (let ([all-start (send f tell)]) (send f put-fixed 0) (let ([snip-list (if snip-list (reverse snip-list) (let loop ([snip start-snip]) (if (and snip (not (eq? snip end-snip))) (cons snip (loop (snip->next snip))) null)))]) (let ([num-headers (let loop ([num-headers 0] [snips snip-list]) (if (null? snips) num-headers (let ([snip (car snips)]) (let ([sclass (snip->snipclass snip)]) (unless sclass (error 'write-snips-to-file "snip has no snipclass")) (if (not (send f do-get-header-flag sclass)) (begin (send f put (send f do-map-position sclass)) (let ([header-start (send f tell)]) (send f put-fixed 0) (let ([header-pos (send f tell)]) (if (not (send sclass write-header f)) #f (begin (send f do-set-header-flag sclass) (let ([header-end (send f tell)]) (send f jump-to header-start) (send f put-fixed (- header-end header-pos)) (send f jump-to header-end) (if (send f ok?) (loop (add1 num-headers) (cdr snips)) #f))))))) (loop num-headers (cdr snips)))))))]) (and num-headers (let ([all-end (send f tell)]) (send f jump-to all-start) (send f put-fixed num-headers) (send f jump-to all-end) (send f put (length snip-list)) (andmap (lambda (snip data) (let ([sclass (snip->snipclass snip)]) (if sclass (send f put (send f do-map-position sclass)) (send f put -1)) (let-values ([(snip-start snip-pos) (if (or (not sclass) (not (send sclass get-s-required?))) (values (send f tell) (begin (send f put-fixed 0) (send f tell))) (values #f #f))]) (let ([style-index (send style-list style-to-index (snip->style snip))]) (when (not style-index) (error 'write-snips-to-file "bad style discovered")) (send f put style-index)) (send snip write f) (and (write-buffer-data f data) (begin (when snip-start (let ([snip-end (send f tell)]) (send f jump-to snip-start) (send f put-fixed (- snip-end snip-pos)) (send f jump-to snip-end))) (send f ok?)))))) snip-list (if extra-data (reverse extra-data) (map (lambda (snip) (send buffer get-snip-data snip)) snip-list)))))))))) ;; ------------------------------------------------------------ ;; Copy and the copy ring: the current clipboard content is stored in ;; common-copy-buffer, etc. to implement the copy ring, then when a ;; copy is started, we moved the wxmb_common-copy-buffer, etc. values ;; into a copy ring. yanking from the ring swaps the values in ;; wxmb_common-copy-buffer, etc. and the ring values and adjust the ;; pointer into the ring. (define copy-depth 0) (define copy-ring-size 30) (define copy-ring-pos 0) (define copy-ring-max 1) (define copy-ring-dest 1) (define copy-ring-buffer1 (make-vector copy-ring-size #f)) (define copy-ring-buffer2 (make-vector copy-ring-size #f)) (define copy-ring-style (make-vector copy-ring-size #f)) (define copy-ring-data (make-vector copy-ring-size #f)) (define common-copy-buffer null) (define common-copy-buffer2 null) (define copy-style-list #f) (define common-copy-region-data #f) (define selection-copy-buffer #f) (define selection-copy-buffer2 #f) (define selection-copy-style-list #f) (define selection-copy-region-data #f) (define (set-common-copy-region-data! v) (set! common-copy-region-data v)) (define (cons-common-copy-buffer! v) (set! common-copy-buffer (cons v common-copy-buffer))) (define (cons-common-copy-buffer2! v) (set! common-copy-buffer2 (cons v common-copy-buffer2))) (define copying-self 0) (define editor-x-selection-mode? ALLOW-X-STYLE-SELECTION?) (define editor-x-selection-owner #f) (define editor-x-selection-allowed #f) (define x-selection-copied? #f) (define x-clipboard-hack? #f) (define (generic-get-data fformat copy-buffer copy-buffer2 copy-styles copy-region-data) (cond [(equal? fformat "TEXT") (string->bytes/utf-8 (let ([out (open-output-string)]) (for-each (lambda (snip) (let ([s (send snip get-text 0 (snip->count snip) #t)]) (display s out))) (reverse copy-buffer)) (let ([s (get-output-string out)]) (cond [(eq? 'macosx (system-type)) ;; change newline to return (regexp-replace* #rx"\r" s "\n")] [(eq? 'windows (system-type)) ;; change newline to return-newline: (regexp-replace* #rx"\n" s "\r\n")] [else s]))))] [(equal? fformat "WXME") (let* ([b (make-object editor-stream-out-bytes-base%)] [mf (make-object editor-stream-out% b)]) (write-editor-version mf b) (write-editor-global-header mf) (and (send mf ok?) (begin (send mf put-fixed 0) (and (write-snips-to-file mf copy-styles copy-buffer #f #f copy-buffer2 #f) (begin (send mf put-fixed 0) (write-buffer-data mf copy-region-data)))) (write-editor-global-footer mf) (send b get-bytes)))] [else #""])) (defclass editor-clipboard-client% clipboard-client% (inherit add-type) (super-new) (add-type "TEXT") (add-type "WXME") (define/override (get-data format) (generic-get-data format common-copy-buffer common-copy-buffer2 copy-style-list common-copy-region-data)) (define/override (on-replaced) (void))) (defclass editor-x-clipboard-client% clipboard-client% (inherit add-type) (super-new) (add-type "TEXT") (add-type "WXME") (define/override (get-data format) (cond [(and (not x-selection-copied?) (not editor-x-selection-owner)) ""] [else (when (or (not x-selection-copied?) editor-x-selection-owner) (copy-into-selection)) ;; if nothing is copied (e.g., do-copy is overriden to not copy anything ;; or copies directly to clipboard): (if (not selection-copy-style-list) (if (send the-x-selection-clipboard same-clipboard-client? this) #f (send the-x-selection-clipboard get-clipboard-data format 0)) (generic-get-data format selection-copy-buffer selection-copy-buffer2 selection-copy-style-list selection-copy-region-data))])) (define/override (on-replaced) (if editor-x-selection-owner ;; in case this client replaced itself somewhere along the way: (when (not (send the-x-selection-clipboard same-clipboard-client? this)) (let ([b editor-x-selection-owner]) (set! editor-x-selection-owner #f) (set! x-selection-copied? #f) (send b own-x-selection #f #t #f))) (set! x-selection-copied? #f)))) (define the-editor-clipboard-client (new editor-clipboard-client%)) (define the-editor-x-clipboard-client (new editor-x-clipboard-client%)) (define/top (editor-set-x-selection-mode [any? on?]) (when ALLOW-X-STYLE-SELECTION? (set! editor-x-selection-mode? (and on? #t)) (when (and (not on?) (send the-x-selection-clipboard same-clipboard-client? the-editor-x-clipboard-client)) (send the-x-selection-clipboard set-clipboard-string "" 0)))) (define (copy-into-selection) ;; copy all the snips: (set! x-clipboard-hack? #t) ;; save normal buffers: (let ([save-buffer common-copy-buffer] [save-buffer2 common-copy-buffer2] [save-styles copy-style-list] [save-data common-copy-region-data]) ;; set up new selection buffers, and redirect: (set! common-copy-buffer null) (set! common-copy-buffer2 null) (set! copy-style-list #f) (set! common-copy-region-data #f) (send editor-x-selection-owner copy #f 0) ;; move "normal" buffers to selection: (set! selection-copy-buffer common-copy-buffer) (set! selection-copy-buffer2 common-copy-buffer2) (set! selection-copy-style-list copy-style-list) (set! selection-copy-region-data common-copy-region-data) ;; restore normal buffers: (set! common-copy-buffer save-buffer) (set! common-copy-buffer2 save-buffer2) (set! copy-style-list save-styles) (set! common-copy-region-data save-data)) (set! x-clipboard-hack? #f)) ;; ------------------------------------------------------------ (define (read-buffer-data f) (let loop ([data #f]) (let-boxes ([extra-data-index 0]) (send f get extra-data-index) (if (zero? extra-data-index) data (let ([dclass (send (send f get-s-bdl) find-by-map-position f extra-data-index)]) (let ([datalen (if (or (not dclass) (not (send dclass get-s-required?))) (let-boxes ([datalen 0]) (send f get datalen) datalen) -1)]) (if dclass (let ([start (send f tell)]) (when (datalen . >= . 0) (send f set-boundary datalen)) (let ([newdata (send dclass read f)]) (and newdata (begin (send newdata set-s-next data) (let ([data newdata]) (when (datalen . >= . 0) (let ([rcount (- (send f tell) start)]) (when (rcount . < . datalen) (error 'read-buffer-data "underread (caused by file corruption?)")) (send f skip (- datalen rcount))) (send f remove-boundary)) (and (send f ok?) (loop data))))))) ;; unknown extra data (begin (send f skip datalen) (and (send f ok?) (loop data)))))))))) ;; ------------------------------------------------------------ (define MRED-READER-STR #"#reader(lib\"read.ss\"\"wxme\")") (define MRED-START-STR #"WXME") (define MRED-FORMAT-STR #"01") (define MRED-VERSION-STR #"08") (define MRED-VERSION-RX #rx"^0[1-8]$") (define (write-editor-version f b) (send b write-bytes MRED-READER-STR) (send b write-bytes MRED-START-STR) (send b write-bytes MRED-FORMAT-STR) (send b write-bytes MRED-VERSION-STR) (send b write-bytes #" ## ") (not (send b bad?))) (define MRED-READER+START-STR (bytes-append MRED-READER-STR MRED-START-STR)) (define (detect-wxme-file who f peek?) (let* ([l1 (bytes-length MRED-START-STR)] [s (if peek? (peek-bytes l1 0 f) (read-bytes l1 f))]) (or (equal? s MRED-START-STR) (and (equal? s (subbytes MRED-READER-STR 0 l1)) (let ([s (bytes-append s (let ([v (if peek? (peek-bytes (- (bytes-length MRED-READER+START-STR) l1) l1 f) (read-bytes (- (bytes-length MRED-READER+START-STR) l1) f))]) (if (eof-object? v) "" v)))]) (equal? s MRED-READER+START-STR)))))) (define (read-editor-version mf b parse-format? [show-errors? #t]) (and (or (not parse-format?) (let* ([n1 (bytes-length MRED-START-STR)] [vbuf (make-vector n1)]) (let ([n (send b read vbuf)]) (or (and (= n (vector-length vbuf)) (bytes=? MRED-START-STR (string->bytes/latin-1 (list->string (vector->list vbuf))))) ;; maybe we have a #reader... prefix? (let* ([n2 (bytes-length MRED-READER-STR)] [vbuf2 (make-vector (- n2 n1))]) (let ([n (send b read vbuf2)]) (and (= n (- n2 n1)) (bytes=? MRED-READER-STR (string->bytes/latin-1 (string-append (list->string (vector->list vbuf)) (list->string (vector->list vbuf2))))) ;; yes, so try reading start again. (let ([n (send b read vbuf)]) (and (= n (vector-length vbuf)) (bytes=? MRED-START-STR (string->bytes/latin-1 (list->string (vector->list vbuf))))))))) (if show-errors? (error (method-name 'pasteboard%: 'insert-file) "not a WXME file") #f))))) (begin (let* ([n1 (bytes-length MRED-FORMAT-STR)] [vbuf (make-vector n1)]) (let ([n (send b read vbuf)]) (send mf set-s-read-format (string->bytes/latin-1 (list->string (vector->list vbuf)))))) (let* ([n1 (bytes-length MRED-VERSION-STR)] [vbuf (make-vector n1)]) (let ([n (send b read vbuf)]) (and (= n n1) (send mf set-s-read-version (string->bytes/latin-1 (list->string (vector->list vbuf))))))) (check-format-and-version mf b show-errors?)))) (define (read-editor-global-header f) (send (send f get-s-scl) reset-header-flags f) (if (not (send (send f get-s-scl) read f)) #f (begin (setup-style-reads-writes f) (send (send f get-s-bdl) read f)))) (define (read-editor-global-footer f) (done-style-reads-writes f) (send (send f get-s-scl) reset-header-flags f) #t) (define (write-editor-global-header f) (send f pretty-start) (send (send f get-s-scl) reset-header-flags f) (if (not (send (send f get-s-scl) write f)) #f (begin (setup-style-reads-writes f) (send (send f get-s-bdl) write f)))) (define (write-editor-global-footer f) (done-style-reads-writes f) (send (send f get-s-scl) reset-header-flags f) (send f pretty-finish) #t) (define (check-format-and-version s b show-errors?) (and (or (bytes=? (send s get-s-read-format) MRED-FORMAT-STR) (if show-errors? (error 'load-file "unknown format number in WXME file format: ~s" (send s get-s-read-format)) #f)) (or (regexp-match MRED-VERSION-RX (send s get-s-read-format)) (if show-errors? (error 'load-file "unknown version number in WXME file format") #f)) (if ((send s get-wxme-version) . > . 3) ;; need to skip " ## " (let* ([v (make-vector 4)] [n (send b read v)]) (or (and (= n 4) (char=? (vector-ref v 0) #\space) (char=? (vector-ref v 1) #\#) (char=? (vector-ref v 2) #\#) (member (vector-ref v 3) '(#\space #\return #\newline))) (if show-errors? (error 'load-file "WXME file missing ' ## ' mark") #f))) #t)))