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 ;; most notable being the `vlf-move-to-chunk' function.
  27
  28 ;;; Code:
  29
  30 (defcustom vlf-batch-size 1024
  31   "Defines how large each batch of file data is (in bytes)."
  32   :group 'vlf :type 'integer)
  33 (put 'vlf-batch-size 'permanent-local t)
  34
  35 (defcustom vlf-before-chunk-update nil
  36   "Hook that runs before chunk update."
  37   :group 'vlf :type 'hook)
  38
  39 (defcustom vlf-after-chunk-update nil
  40   "Hook that runs after chunk update."
  41   :group 'vlf :type 'hook)
  42
  43 ;;; Keep track of file position.
  44 (defvar vlf-start-pos 0
  45   "Absolute position of the visible chunk start.")
  46 (make-variable-buffer-local 'vlf-start-pos)
  47 (put 'vlf-start-pos 'permanent-local t)
  48
  49 (defvar vlf-end-pos 0 "Absolute position of the visible chunk end.")
  50 (make-variable-buffer-local 'vlf-end-pos)
  51 (put 'vlf-end-pos 'permanent-local t)
  52
  53 (defvar vlf-file-size 0 "Total size of presented file.")
  54 (make-variable-buffer-local 'vlf-file-size)
  55 (put 'vlf-file-size 'permanent-local t)
  56
  57 (defconst vlf-sample-size 24
  58   "Minimal number of bytes that can be properly decoded.")
  59
  60 (defun vlf-get-file-size (file)
  61   "Get size in bytes of FILE."
  62   (or (nth 7 (file-attributes file)) 0))
  63
  64 (defun vlf-verify-size (&optional update-visited-time)
  65   "Update file size information if necessary and visited file time.
  66 If non-nil, UPDATE-VISITED-TIME."
  67   (unless (verify-visited-file-modtime (current-buffer))
  68     (setq vlf-file-size (vlf-get-file-size buffer-file-truename))
  69     (if update-visited-time
  70         (set-visited-file-modtime))))
  71
  72 (unless (fboundp 'file-size-human-readable)
  73   (defun file-size-human-readable (file-size)
  74     "Print FILE-SIZE in MB."
  75     (format "%.3fMB" (/ file-size 1048576.0))))
  76
  77 (defun vlf-update-buffer-name ()
  78   "Update the current buffer name."
  79   (rename-buffer (format "%s(%d/%d)[%s]"
  80                          (file-name-nondirectory buffer-file-name)
  81                          (/ vlf-end-pos vlf-batch-size)
  82                          (/ vlf-file-size vlf-batch-size)
  83                          (file-size-human-readable vlf-batch-size))
  84                  t))
  85
  86 (defmacro vlf-with-undo-disabled (&rest body)
  87   "Execute BODY with temporarily disabled undo."
  88   `(let ((undo-list buffer-undo-list))
  89      (setq buffer-undo-list t)
  90      (unwind-protect (progn ,@body)
  91        (setq buffer-undo-list undo-list))))
  92
  93 (defun vlf-move-to-chunk (start end &optional minimal)
  94   "Move to chunk enclosed by START END bytes.
  95 When given MINIMAL flag, skip non important operations.
  96 If same as current chunk is requested, do nothing.
  97 Return number of bytes moved back for proper decoding and number of
  98 bytes added to the end."
  99   (vlf-verify-size)
 100   (cond ((or (<= end start) (<= end 0)
 101              (<= vlf-file-size start))
 102          (when (or (not (buffer-modified-p))
 103                    (y-or-n-p "Chunk modified, are you sure? "))
 104            (erase-buffer)
 105            (set-buffer-modified-p nil)
 106            (let ((place (if (<= vlf-file-size start)
 107                             vlf-file-size
 108                           0)))
 109              (setq vlf-start-pos place
 110                    vlf-end-pos place)
 111              (if (not minimal)
 112                  (vlf-update-buffer-name))
 113              (cons (- start place) (- place end)))))
 114         ((or (/= start vlf-start-pos)
 115              (/= end vlf-end-pos))
 116          (let ((shifts (vlf-move-to-chunk-1 start end)))
 117            (and shifts (not minimal)
 118                 (vlf-update-buffer-name))
 119            shifts))))
 120
 121 (defun vlf-move-to-chunk-1 (start end)
 122   "Move to chunk enclosed by START END keeping as much edits if any.
 123 Return number of bytes moved back for proper decoding and number of
 124 bytes added to the end."
 125   (widen)
 126   (let* ((modified (buffer-modified-p))
 127          (start (max 0 start))
 128          (end (min end vlf-file-size))
 129          (edit-end (if modified
 130                        (+ vlf-start-pos
 131                           (length (encode-coding-region
 132                                    (point-min) (point-max)
 133                                    buffer-file-coding-system t)))
 134                      vlf-end-pos)))
 135     (cond
 136      ((or (< edit-end start) (< end vlf-start-pos)
 137           (not (verify-visited-file-modtime (current-buffer))))
 138       (when (or (not modified)
 139                 (y-or-n-p "Chunk modified, are you sure? ")) ;full chunk renewal
 140         (set-buffer-modified-p nil)
 141         (vlf-move-to-chunk-2 start end)))
 142      ((and (= start vlf-start-pos) (= end edit-end))
 143       (or modified (vlf-move-to-chunk-2 start end)))
 144      ((or (and (<= start vlf-start-pos) (<= edit-end end))
 145           (not modified)
 146           (y-or-n-p "Chunk modified, are you sure? "))
 147       (run-hooks 'vlf-before-chunk-update)
 148       (let ((shift-start 0)
 149             (shift-end 0))
 150         (let ((pos (+ (position-bytes (point)) vlf-start-pos))
 151               (inhibit-read-only t))
 152           (cond ((= end vlf-start-pos)
 153                  (or (eq buffer-undo-list t)
 154                      (setq buffer-undo-list nil))
 155                  (vlf-with-undo-disabled (erase-buffer))
 156                  (setq modified nil))
 157                 ((< end edit-end)
 158                  (setq end (car (vlf-delete-region
 159                                  (point-min) vlf-start-pos edit-end
 160                                  end (min (or (byte-to-position
 161                                                (- end vlf-start-pos))
 162                                               (point-min))
 163                                           (point-max))
 164                                  nil))))
 165                 ((< edit-end end)
 166                  (vlf-with-undo-disabled
 167                   (setq shift-end (cdr (vlf-insert-file-contents
 168                                         vlf-end-pos end nil t
 169                                         (point-max)))))))
 170           (setq vlf-end-pos (+ end shift-end))
 171           (cond ((= start edit-end)
 172                  (or (eq buffer-undo-list t)
 173                      (setq buffer-undo-list nil))
 174                  (vlf-with-undo-disabled
 175                   (delete-region (point-min) (point)))
 176                  (setq modified nil))
 177                 ((< vlf-start-pos start)
 178                  (let ((del-info (vlf-delete-region
 179                                   (point-min) vlf-start-pos
 180                                   vlf-end-pos start
 181                                   (min (or (byte-to-position
 182                                             (- start vlf-start-pos))
 183                                            (point))
 184                                        (point-max)) t)))
 185                    (setq start (car del-info))
 186                    (vlf-shift-undo-list (- (point-min)
 187                                            (cdr del-info)))))
 188                 ((< start vlf-start-pos)
 189                  (let ((edit-end-pos (point-max)))
 190                    (vlf-with-undo-disabled
 191                     (setq shift-start (car (vlf-insert-file-contents
 192                                             start vlf-start-pos t nil
 193                                             edit-end-pos)))
 194                     (goto-char (point-min))
 195                     (insert (delete-and-extract-region
 196                              edit-end-pos (point-max))))
 197                    (vlf-shift-undo-list (- (point-max)
 198                                            edit-end-pos)))))
 199           (setq start (- start shift-start))
 200           (goto-char (or (byte-to-position (- pos start))
 201                          (byte-to-position (- pos vlf-start-pos))
 202                          (point-max)))
 203           (setq vlf-start-pos start))
 204         (set-buffer-modified-p modified)
 205         (set-visited-file-modtime)
 206         (run-hooks 'vlf-after-chunk-update)
 207         (cons shift-start shift-end))))))
 208
 209 (defun vlf-move-to-chunk-2 (start end)
 210   "Unconditionally move to chunk enclosed by START END bytes.
 211 Return number of bytes moved back for proper decoding and number of
 212 bytes added to the end."
 213   (run-hooks 'vlf-before-chunk-update)
 214   (vlf-verify-size t)
 215   (setq vlf-start-pos (max 0 start)
 216         vlf-end-pos (min end vlf-file-size))
 217   (let (shifts)
 218     (let ((inhibit-read-only t)
 219           (pos (position-bytes (point))))
 220       (vlf-with-undo-disabled
 221        (erase-buffer)
 222        (setq shifts (vlf-insert-file-contents vlf-start-pos
 223                                               vlf-end-pos t t)
 224              vlf-start-pos (- vlf-start-pos (car shifts))
 225              vlf-end-pos (+ vlf-end-pos (cdr shifts)))
 226        (goto-char (or (byte-to-position (+ pos (car shifts)))
 227                       (point-max)))))
 228     (set-buffer-modified-p nil)
 229     (or (eq buffer-undo-list t)
 230         (setq buffer-undo-list nil))
 231     (run-hooks 'vlf-after-chunk-update)
 232     shifts))
 233
 234 (defun vlf-insert-file-contents (start end adjust-start adjust-end
 235                                        &optional position)
 236   "Adjust chunk at absolute START to END till content can be\
 237 properly decoded.  ADJUST-START determines if trying to prepend bytes
 238 to the beginning, ADJUST-END - append to the end.
 239 Use buffer POSITION as start if given.
 240 Return number of bytes moved back for proper decoding and number of
 241 bytes added to the end."
 242   (setq adjust-start (and adjust-start (not (zerop start)))
 243         adjust-end (and adjust-end (< end vlf-file-size))
 244         position (or position (point-min)))
 245   (goto-char position)
 246   (let ((shift-start 0)
 247         (shift-end 0)
 248         (safe-end (if adjust-end
 249                       (min vlf-file-size (+ end 4))
 250                     end)))
 251     (if adjust-start
 252         (setq shift-start (vlf-adjust-start start safe-end position
 253                                             adjust-end)
 254               start (- start shift-start))
 255       (vlf-insert-file-contents-1 start safe-end))
 256     (if adjust-end
 257         (setq shift-end (- (car (vlf-delete-region position start
 258                                                    safe-end end
 259                                                    (point-max)
 260                                                    nil 'start))
 261                            end)))
 262     (cons shift-start shift-end)))
 263
 264 (defun vlf-insert-file-contents-1 (start end)
 265   "Extract decoded file bytes START to END."
 266   (insert-file-contents buffer-file-name nil start end))
 267
 268 (defun vlf-adjust-start (start end position adjust-end)
 269   "Adjust chunk beginning at absolute START to END till content can\
 270 be properly decoded.  Use buffer POSITION as start.
 271 ADJUST-END is non-nil if end would be adjusted later.
 272 Return number of bytes moved back for proper decoding."
 273   (let* ((safe-start (max 0 (- start 4)))
 274          (sample-end (min end (+ safe-start vlf-sample-size)))
 275          (chunk-size (- sample-end safe-start))
 276          (strict (or (= sample-end vlf-file-size)
 277                      (and (not adjust-end) (= sample-end end))))
 278          (shift 0))
 279     (while (and (progn (vlf-insert-file-contents-1 safe-start
 280                                                    sample-end)
 281                        (not (zerop safe-start)))
 282                 (< shift 3)
 283                 (let ((diff (- chunk-size
 284                                (length
 285                                 (encode-coding-region
 286                                  position (point-max)
 287                                  buffer-file-coding-system t)))))
 288                   (if strict
 289                       (not (zerop diff))
 290                     (or (< diff -3) (< 0 diff)))))
 291       (setq shift (1+ shift)
 292             safe-start (1- safe-start)
 293             chunk-size (1+ chunk-size))
 294       (delete-region position (point-max)))
 295     (setq safe-start (car (vlf-delete-region position safe-start
 296                                              sample-end start
 297                                              position t 'start)))
 298     (unless (= sample-end end)
 299       (delete-region position (point-max))
 300       (vlf-insert-file-contents-1 safe-start end))
 301     (- start safe-start)))
 302
 303 (defun vlf-delete-region (position start end border cut-point from-start
 304                                    &optional encode-direction)
 305   "Delete from chunk starting at POSITION enclosing absolute file\
 306 positions START to END at absolute position BORDER.  Start search for
 307 best cut at CUT-POINT.  Delete from buffer beginning if FROM-START is
 308 non nil or up to buffer end otherwise.  ENCODE-DIRECTION determines
 309 which side of the region to use to calculate cut position's absolute
 310 file position.  Possible values are: `start' - from the beginning;
 311 `end' - from end; nil - the shorter side.
 312 Return actual absolute position of new border and buffer point at
 313 which deletion was performed."
 314   (let* ((encode-from-end (if encode-direction
 315                               (eq encode-direction 'end)
 316                             (< (- end border) (- border start))))
 317          (dist (if encode-from-end
 318                    (- end (length (encode-coding-region
 319                                    cut-point (point-max)
 320                                    buffer-file-coding-system t)))
 321                  (+ start (length (encode-coding-region
 322                                    position cut-point
 323                                    buffer-file-coding-system t)))))
 324          (len 0))
 325     (if (< border dist)
 326         (while (< border dist)
 327           (setq len (length (encode-coding-region
 328                              cut-point (1- cut-point)
 329                              buffer-file-coding-system t))
 330                 cut-point (1- cut-point)
 331                 dist (- dist len)))
 332       (while (< dist border)
 333         (setq len (length (encode-coding-region
 334                            cut-point (1+ cut-point)
 335                            buffer-file-coding-system t))
 336               cut-point (1+ cut-point)
 337               dist (+ dist len)))
 338       (or (= dist border)
 339           (setq cut-point (1- cut-point)
 340                 dist (- dist len))))
 341     (and (not from-start) (/= dist border)
 342          (setq cut-point (1+ cut-point)
 343                dist (+ dist len)))
 344     (vlf-with-undo-disabled
 345      (if from-start (delete-region position cut-point)
 346        (delete-region cut-point (point-max))))
 347     (cons dist (1+ cut-point))))
 348
 349 (defun vlf-shift-undo-list (n)
 350   "Shift undo list element regions by N."
 351   (or (eq buffer-undo-list t)
 352       (setq buffer-undo-list
 353             (nreverse
 354              (let ((min (point-min))
 355                    undo-list)
 356                (catch 'end
 357                  (dolist (el buffer-undo-list undo-list)
 358                    (push
 359                     (cond
 360                      ((null el) nil)
 361                      ((numberp el) (let ((pos (+ el n)))
 362                                      (if (< pos min)
 363                                          (throw 'end undo-list)
 364                                        pos)))
 365                      (t (let ((head (car el)))
 366                           (cond ((numberp head)
 367                                  (let ((beg (+ head n)))
 368                                    (if (< beg min)
 369                                        (throw 'end undo-list)
 370                                      (cons beg (+ (cdr el) n)))))
 371                                 ((stringp head)
 372                                  (let* ((pos (cdr el))
 373                                         (positive (< 0 pos))
 374                                         (new (+ (abs pos) n)))
 375                                    (if (< new min)
 376                                        (throw 'end undo-list)
 377                                      (cons head (if positive
 378                                                     new
 379                                                   (- new))))))
 380                                 ((null head)
 381                                  (let ((beg (+ (nth 3 el) n)))
 382                                    (if (< beg min)
 383                                        (throw 'end undo-list)
 384                                      (cons
 385                                       nil
 386                                       (cons
 387                                        (cadr el)
 388                                        (cons
 389                                         (nth 2 el)
 390                                         (cons beg
 391                                               (+ (cddr
 392                                                   (cddr el)) n))))))))
 393                                 ((and (eq head 'apply)
 394                                       (numberp (cadr el)))
 395                                  (let ((beg (+ (nth 2 el) n)))
 396                                    (if (< beg min)
 397                                        (throw 'end undo-list)
 398                                      (cons
 399                                       'apply
 400                                       (cons
 401                                        (cadr el)
 402                                        (cons
 403                                         beg
 404                                         (cons
 405                                          (+ (nth 3 el) n)
 406                                          (cons (nth 4 el)
 407                                                (cdr (last el))))))))))
 408                                 (t el)))))
 409                     undo-list))))))))
 410
 411 (provide 'vlf-base)
 412
 413 ;;; vlf-base.el ends here