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