code.delx.au - gnu-emacs-elpa/blob - packages/vlf/vlf-base.el

   1 ;;; vlf-base.el --- VLF primitive operations  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
   4
   5 ;; Keywords: large files, chunk
   6 ;; Author: Andrey Kotlarski <m00naticus@gmail.com>
   7 ;; URL: https://github.com/m00natic/vlfi
   8
   9 ;; This file is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 3, or (at your option)
  12 ;; any later version.
  13
  14 ;; This file is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25 ;; This package provides basic chunk operations for VLF
  26
  27 ;;; Code:
  28
  29 (defconst vlf-min-chunk-size 16
  30   "Minimal number of bytes that can be properly decoded.")
  31
  32 (defconst vlf-partial-decode-shown
  33   (cond ((< emacs-major-version 24) t)
  34         ((< 24 emacs-major-version) nil)
  35         (t ;; TODO: use (< emacs-minor-version 4) after 24.4 release
  36          (string-lessp emacs-version "24.3.5")))
  37   "Indicates whether partial decode codes are displayed.")
  38
  39 (defun vlf-move-to-chunk (start end &optional minimal)
  40   "Move to chunk determined by START END.
  41 When given MINIMAL flag, skip non important operations.
  42 If same as current chunk is requested, do nothing.
  43 Return number of bytes moved back for proper decoding and number of
  44 bytes added to the end."
  45   (unless (and (= start vlf-start-pos)
  46                (= end vlf-end-pos))
  47     (vlf-verify-size)
  48     (let ((shifts (vlf-move-to-chunk-1 start end)))
  49       (and shifts (not minimal)
  50            (vlf-update-buffer-name))
  51       shifts)))
  52
  53 (defun vlf-move-to-chunk-1 (start end)
  54   "Move to chunk determined by START END keeping as much edits if any.
  55 Return number of bytes moved back for proper decoding and number of
  56 bytes added to the end."
  57   (let* ((modified (buffer-modified-p))
  58          (start (max 0 start))
  59          (end (min end vlf-file-size))
  60          (edit-end (if modified
  61                        (+ vlf-start-pos
  62                           (length (encode-coding-region
  63                                    (point-min) (point-max)
  64                                    buffer-file-coding-system t)))
  65                      vlf-end-pos)))
  66     (cond
  67      ((and (= start vlf-start-pos) (= end edit-end))
  68       (or modified (vlf-move-to-chunk-2 start end)))
  69      ((or (<= edit-end start) (<= end vlf-start-pos))
  70       (when (or (not modified)
  71                 (y-or-n-p "Chunk modified, are you sure? ")) ;full chunk renewal
  72         (set-buffer-modified-p nil)
  73         (vlf-move-to-chunk-2 start end)))
  74      ((or (and (<= start vlf-start-pos) (<= edit-end end))
  75           (not modified)
  76           (y-or-n-p "Chunk modified, are you sure? "))
  77       (let ((shift-start 0)
  78             (shift-end 0))
  79         (let ((pos (+ (position-bytes (point)) vlf-start-pos))
  80               (inhibit-read-only t))
  81           (cond ((< end edit-end)
  82                  (let* ((del-pos (1+ (byte-to-position
  83                                       (- end vlf-start-pos))))
  84                         (del-len (length (encode-coding-region
  85                                           del-pos (point-max)
  86                                           buffer-file-coding-system
  87                                           t))))
  88                    (setq end (- (if (zerop vlf-end-pos)
  89                                     vlf-file-size
  90                                   vlf-end-pos)
  91                                 del-len))
  92                    (vlf-with-undo-disabled
  93                     (delete-region del-pos (point-max)))))
  94                 ((< edit-end end)
  95                  (if (and (not vlf-partial-decode-shown)
  96                           (< (- end vlf-end-pos) 4))
  97                      (setq end vlf-end-pos)
  98                    (vlf-with-undo-disabled
  99                     (setq shift-end (cdr (vlf-insert-file-contents
 100                                           vlf-end-pos end nil t
 101                                           (point-max))))))))
 102           (cond ((< vlf-start-pos start)
 103                  (let* ((del-pos (1+ (byte-to-position
 104                                       (- start vlf-start-pos))))
 105                         (del-len (length (encode-coding-region
 106                                           (point-min) del-pos
 107                                           buffer-file-coding-system
 108                                           t))))
 109                    (setq start (+ vlf-start-pos del-len))
 110                    (vlf-with-undo-disabled
 111                     (delete-region (point-min) del-pos))
 112                    (vlf-shift-undo-list (- 1 del-pos))))
 113                 ((< start vlf-start-pos)
 114                  (if (and (not vlf-partial-decode-shown)
 115                           (< (- vlf-start-pos start) 4))
 116                      (setq start vlf-start-pos)
 117                    (let ((edit-end-pos (point-max)))
 118                      (vlf-with-undo-disabled
 119                       (setq shift-start (car (vlf-insert-file-contents
 120                                               start vlf-start-pos
 121                                               t nil edit-end-pos)))
 122                       (goto-char (point-min))
 123                       (insert (delete-and-extract-region
 124                                edit-end-pos (point-max))))
 125                      (vlf-shift-undo-list (- (point-max) edit-end-pos))))))
 126           (setq start (- start shift-start))
 127           (goto-char (or (byte-to-position (- pos start))
 128                          (byte-to-position (- pos vlf-start-pos))
 129                          (point-max)))
 130           (setq vlf-start-pos start
 131                 vlf-end-pos (+ end shift-end)))
 132         (set-buffer-modified-p modified)
 133         (cons shift-start shift-end))))))
 134
 135 (defun vlf-move-to-chunk-2 (start end)
 136   "Unconditionally move to chunk determined by START END.
 137 Return number of bytes moved back for proper decoding and number of
 138 bytes added to the end."
 139   (setq vlf-start-pos (max 0 start)
 140         vlf-end-pos (min end vlf-file-size))
 141   (let (shifts)
 142     (let ((inhibit-read-only t)
 143           (pos (position-bytes (point))))
 144       (vlf-with-undo-disabled
 145        (erase-buffer)
 146        (setq shifts (vlf-insert-file-contents vlf-start-pos
 147                                               vlf-end-pos t t)
 148              vlf-start-pos (- vlf-start-pos (car shifts))
 149              vlf-end-pos (+ vlf-end-pos (cdr shifts)))
 150        (goto-char (or (byte-to-position (+ pos (car shifts)))
 151                       (point-max)))))
 152     (set-buffer-modified-p nil)
 153     (setq buffer-undo-list nil)
 154     (set-visited-file-modtime)
 155     shifts))
 156
 157 (defun vlf-insert-file-contents (start end adjust-start adjust-end
 158                                        &optional position)
 159   "Adjust chunk at absolute START to END till content can be\
 160 properly decoded.  ADJUST-START determines if trying to prepend bytes\
 161  to the beginning, ADJUST-END - append to the end.
 162 Use buffer POSITION as start if given.
 163 Return number of bytes moved back for proper decoding and number of
 164 bytes added to the end."
 165   (setq adjust-start (and adjust-start (not (zerop start)))
 166         adjust-end (and adjust-end (< end vlf-file-size))
 167         position (or position (point-min)))
 168   (let ((shift-start 0)
 169         (shift-end 0))
 170     (if adjust-start
 171         (setq shift-start (vlf-adjust-start start end position
 172                                             adjust-end)
 173               start (- start shift-start))
 174       (setq shift-end (vlf-insert-content-safe start end position)
 175             end (+ end shift-end)))
 176     (if adjust-end
 177         (setq shift-end (+ shift-end
 178                            (vlf-adjust-end start end position))))
 179     (cons shift-start shift-end)))
 180
 181 (defun vlf-adjust-start (start end position adjust-end)
 182   "Adjust chunk beginning at absolute START to END till content can\
 183 be properly decoded.  Use buffer POSITION as start.
 184 ADJUST-END is non-nil if end would be adjusted later.
 185 Return number of bytes moved back for proper decoding."
 186   (let* ((min-end (min end (+ start vlf-min-chunk-size)))
 187          (chunk-size (- min-end start))
 188          (strict (and (not adjust-end) (= min-end end)))
 189          (shift (vlf-insert-content-safe start min-end position t)))
 190     (setq start (- start shift))
 191     (while (and (not (zerop start))
 192                 (< shift 3)
 193                 (let ((diff (- chunk-size
 194                                (length
 195                                 (encode-coding-region
 196                                  position (point-max)
 197                                  buffer-file-coding-system t)))))
 198                   (cond (strict (not (zerop diff)))
 199                         (vlf-partial-decode-shown
 200                          (or (< diff -3) (< 0 diff)))
 201                         (t (or (< diff 0) (< 3 diff))))))
 202       (setq shift (1+ shift)
 203             start (1- start)
 204             chunk-size (1+ chunk-size))
 205       (delete-region position (point-max))
 206       (insert-file-contents buffer-file-name nil start min-end))
 207     (unless (= min-end end)
 208       (delete-region position (point-max))
 209       (insert-file-contents buffer-file-name nil start end))
 210     shift))
 211
 212 (defun vlf-adjust-end (start end position)
 213   "Adjust chunk end at absolute START to END till content can be\
 214 properly decoded starting at POSITION.
 215 Return number of bytes added for proper decoding."
 216   (let ((shift 0))
 217     (if vlf-partial-decode-shown
 218         (let ((new-pos (max position
 219                             (- (point-max) vlf-min-chunk-size))))
 220           (if (< position new-pos)
 221               (setq start (+ start (length (encode-coding-region
 222                                             position new-pos
 223                                             buffer-file-coding-system
 224                                             t)))
 225                     position new-pos))))
 226     (let ((chunk-size (- end start)))
 227       (goto-char (point-max))
 228       (while (and (< shift 3)
 229                   (< end vlf-file-size)
 230                   (or (eq (char-charset (preceding-char)) 'eight-bit)
 231                       (/= chunk-size
 232                           (length (encode-coding-region
 233                                    position (point-max)
 234                                    buffer-file-coding-system t)))))
 235         (setq shift (1+ shift)
 236               end (1+ end)
 237               chunk-size (1+ chunk-size))
 238         (delete-region position (point-max))
 239         (insert-file-contents buffer-file-name nil start end)
 240         (goto-char (point-max))))
 241     shift))
 242
 243 (defun vlf-insert-content-safe (start end position &optional shift-start)
 244   "Insert file content from absolute START to END of file at\
 245 POSITION.  Adjust start if SHIFT-START is non nil, end otherwise.
 246 Clean up if no characters are inserted."
 247   (goto-char position)
 248   (let ((shift 0))
 249     (while (and (< shift 3)
 250                 (zerop (cadr (insert-file-contents buffer-file-name
 251                                                    nil start end)))
 252                 (if shift-start
 253                     (not (zerop start))
 254                   (< end vlf-file-size)))
 255       ;; TODO: this seems like regression after Emacs 24.3
 256       (message "Buffer content may be broken")
 257       (setq shift (1+ shift))
 258       (if shift-start
 259           (setq start (1- start))
 260         (setq end (1+ end)))
 261       (delete-region position (point-max)))
 262     shift))
 263
 264 (defun vlf-shift-undo-list (n)
 265   "Shift undo list element regions by N."
 266   (or (eq buffer-undo-list t)
 267       (setq buffer-undo-list
 268             (nreverse
 269              (let ((min (point-min))
 270                    undo-list)
 271                (catch 'end
 272                  (dolist (el buffer-undo-list undo-list)
 273                    (push
 274                     (cond
 275                      ((null el) nil)
 276                      ((numberp el) (let ((pos (+ el n)))
 277                                      (if (< pos min)
 278                                          (throw 'end undo-list)
 279                                        pos)))
 280                      (t (let ((head (car el)))
 281                           (cond ((numberp head)
 282                                  (let ((beg (+ head n)))
 283                                    (if (< beg min)
 284                                        (throw 'end undo-list)
 285                                      (cons beg (+ (cdr el) n)))))
 286                                 ((stringp head)
 287                                  (let* ((pos (cdr el))
 288                                         (positive (< 0 pos))
 289                                         (new (+ (abs pos) n)))
 290                                    (if (< new min)
 291                                        (throw 'end undo-list)
 292                                      (cons head (if positive
 293                                                     new
 294                                                   (- new))))))
 295                                 ((null head)
 296                                  (let ((beg (+ (nth 3 el) n)))
 297                                    (if (< beg min)
 298                                        (throw 'end undo-list)
 299                                      (cons
 300                                       nil
 301                                       (cons
 302                                        (cadr el)
 303                                        (cons
 304                                         (nth 2 el)
 305                                         (cons beg
 306                                               (+ (cddr
 307                                                   (cddr el)) n))))))))
 308                                 ((and (eq head 'apply)
 309                                       (numberp (cadr el)))
 310                                  (let ((beg (+ (nth 2 el) n)))
 311                                    (if (< beg min)
 312                                        (throw 'end undo-list)
 313                                      (cons
 314                                       'apply
 315                                       (cons
 316                                        (cadr el)
 317                                        (cons
 318                                         beg
 319                                         (cons
 320                                          (+ (nth 3 el) n)
 321                                          (cons (nth 4 el)
 322                                                (cdr (last el))))))))))
 323                                 (t el)))))
 324                     undo-list))))))))
 325
 326 (provide 'vlf-base)
 327
 328 ;;; vlf-base.el ends here