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