1 ;;; vlf-base.el --- VLF primitive operations -*- lexical-binding: t -*-
3 ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
5 ;; Keywords: large files, chunk
6 ;; Author: Andrey Kotlarski <m00naticus@gmail.com>
7 ;; URL: https://github.com/m00natic/vlfi
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)
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.
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.
25 ;; This package provides basic chunk operations for VLF,
26 ;; most notable being the `vlf-move-to-chunk' function.
32 (defcustom vlf-before-chunk-update-hook nil
33 "Hook that runs before chunk update."
34 :group 'vlf :type 'hook)
36 (defcustom vlf-after-chunk-update-hook nil
37 "Hook that runs after chunk update."
38 :group 'vlf :type 'hook)
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)
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)
52 (defconst vlf-sample-size 24
53 "Minimal number of bytes that can be properly decoded.")
55 (defun vlf-get-file-size (file)
56 "Get size in bytes of FILE."
57 (or (nth 7 (file-attributes file)) 0))
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))))
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))))
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))))
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."
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? "))
92 (set-buffer-modified-p nil)
93 (let ((place (if (<= vlf-file-size start)
96 (setq vlf-start-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))))
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."
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
120 hexl-undo-list buffer-undo-list
122 (vlf-tune-dehexlify))
124 (vlf-tune-encode-length (point-min)
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))
140 (if (consp hexl-undo-list)
141 (setq hexl-undo-list nil))
142 (vlf-move-to-chunk-2 start end)))
144 (not (consp buffer-undo-list)))
145 (vlf-move-to-chunk-2 start end))
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)
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))
164 (setq end (car (vlf-delete-region
165 (point-min) vlf-start-pos
167 (min (or (byte-to-position
168 (- end vlf-start-pos))
173 (vlf-with-undo-disabled
174 (setq shift-end (cdr (vlf-insert-file-contents
175 vlf-end-pos end nil t
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)))
184 ((< vlf-start-pos start)
185 (let ((del-info (vlf-delete-region
186 (point-min) vlf-start-pos
190 (- start vlf-start-pos))
193 (setq start (car del-info))
194 (vlf-shift-undo-list (- (point-min)
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
203 (goto-char (point-min))
204 (insert (delete-and-extract-region
205 edit-end-pos (point-max))))
206 (vlf-shift-undo-list (- (point-max)
208 (setq start (- start shift-start))
209 (goto-char (or (byte-to-position (- pos start))
210 (byte-to-position (- pos vlf-start-pos))
212 (setq vlf-start-pos start))
213 (set-buffer-modified-p modified)
214 (set-visited-file-modtime)
217 (setq restore-hexl nil))
218 (run-hooks 'vlf-after-chunk-update-hook)
219 (cons shift-start shift-end))))))
222 (setq buffer-undo-list hexl-undo-list))
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)
232 (is-hexl (derived-mode-p 'hexl-mode)))
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))))
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
248 (progn (vlf-tune-insert-file-contents-literally
249 vlf-start-pos vlf-end-pos)
251 (setq shifts (vlf-insert-file-contents vlf-start-pos
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)))
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)
265 (defun vlf-insert-file-contents (start end adjust-start adjust-end
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)))
277 (let ((shift-start 0)
279 (safe-end (if adjust-end
280 (min vlf-file-size (+ end 4))
283 (setq shift-start (vlf-adjust-start start safe-end position
285 start (- start shift-start))
286 (vlf-insert-file-contents-1 start safe-end))
288 (setq shift-end (- (car (vlf-delete-region position start
293 (cons shift-start shift-end)))
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))
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))))
310 (while (and (progn (insert-file-contents buffer-file-name
311 nil safe-start sample-end)
312 (not (zerop safe-start)))
314 (let ((diff (- chunk-size
316 (encode-coding-region
318 buffer-file-coding-system t)))))
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
329 (unless (= sample-end end)
330 (delete-region position (point-max))
331 (vlf-insert-file-contents-1 safe-start end))
332 (- start safe-start)))
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
351 (+ start (vlf-tune-encode-length position
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)
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)
368 (setq cut-point (1- cut-point)
370 (and (not from-start) (/= dist border)
371 (setq cut-point (1+ cut-point)
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))))
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)
384 (+ vlf-start-pos (vlf-tune-encode-length (point-min) point)))))
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
391 (let ((min (point-min))
394 (dolist (el buffer-undo-list undo-list)
398 ((numberp el) (let ((pos (+ el n)))
400 (throw 'end undo-list)
402 (t (let ((head (car el)))
403 (cond ((numberp head)
404 (let ((beg (+ head n)))
406 (throw 'end undo-list)
407 (cons beg (+ (cdr el) n)))))
409 (let* ((pos (cdr el))
411 (new (+ (abs pos) n)))
413 (throw 'end undo-list)
414 (cons head (if positive
418 (let ((beg (+ (nth 3 el) n)))
420 (throw 'end undo-list)
430 ((and (eq head 'apply)
432 (let ((beg (+ (nth 2 el) n)))
434 (throw 'end undo-list)
444 (cdr (last el))))))))))
450 ;;; vlf-base.el ends here