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