changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/io/smart-buffer.lisp

changeset 698: 96958d3eb5b0
parent: a37b1d3371fc
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; io/smart-buffer.lisp --- Smart Octet Buffers
     2 
     3 ;; This is ported from Fukamachi's SMART-BUFFER
     4 
     5 ;;; Code:
     6 
     7 (defpackage io/smart-buffer
     8   (:use #:cl
     9         #:io/xsubseq)
    10   (:export :*default-memory-limit*
    11            :*default-disk-limit*
    12            :smart-buffer
    13            :make-smart-buffer
    14            :write-to-buffer
    15            :finalize-buffer
    16            :with-smart-buffer
    17            :buffer-on-memory-p
    18            :delete-stream-file
    19            :delete-temporary-files
    20            :buffer-limit-exceeded))
    21 
    22 (in-package :io/smart-buffer)
    23 
    24 (defvar *default-memory-limit* (expt 2 20))
    25 (defvar *default-disk-limit* (expt 2 30))
    26 
    27 (defvar *temporary-directory*
    28   (uiop:ensure-directory-pathname
    29     (merge-pathnames (format nil "smart-buffer-~36R" (random (expt 36 #-gcl 8 #+gcl 5)))
    30                      (uiop:default-temporary-directory))))
    31 
    32 (defstruct (smart-buffer (:conc-name :buffer-)
    33                          (:constructor %make-smart-buffer))
    34   (memory-limit *default-memory-limit*)
    35   (disk-limit *default-disk-limit*)
    36   (current-len 0)
    37   (on-memory-p t)
    38   (memory-buffer (make-concatenated-xsubseqs))
    39   (disk-buffer nil))
    40 
    41 (defun make-smart-buffer (&rest initargs &key memory-limit disk-limit &allow-other-keys)
    42   (let ((buffer (apply #'%make-smart-buffer initargs)))
    43     (when (and memory-limit
    44                disk-limit
    45                (< disk-limit memory-limit))
    46       (setf (buffer-memory-limit buffer) disk-limit))
    47     buffer))
    48 
    49 (define-condition buffer-limit-exceeded (error)
    50   ((limit :initarg :limit
    51           :initform nil))
    52   (:report (lambda (condition stream)
    53              (format stream "Buffer exceeded the limit~:[~;~:*: ~A~]"
    54                      (slot-value condition 'limit)))))
    55 
    56 (defun write-to-buffer (buffer seq &optional (start 0) (end (length seq)))
    57   (check-type seq (array (unsigned-byte 8) (*)))
    58   (incf (buffer-current-len buffer) (- end start))
    59   (check-limit buffer)
    60   (if (buffer-on-memory-p buffer)
    61       (xnconcf (buffer-memory-buffer buffer) (xsubseq seq start end))
    62       (with-open-file (out (buffer-disk-buffer buffer)
    63                            :direction :output
    64                            :element-type '(unsigned-byte 8)
    65                            :if-exists :append)
    66         (write-sequence seq out :start start :end end))))
    67 
    68 (defun check-limit (buffer)
    69   (cond
    70     ((and (buffer-on-memory-p buffer)
    71           (< (buffer-memory-limit buffer)
    72              (buffer-current-len buffer)))
    73      (when (< (buffer-disk-limit buffer)
    74               (buffer-current-len buffer))
    75        (error 'buffer-limit-exceeded :limit (buffer-disk-limit buffer)))
    76      (setf (buffer-disk-buffer buffer)
    77            (uiop:with-temporary-file (:stream stream :pathname tmp
    78                                       :directory *temporary-directory*
    79                                       :direction :output
    80                                       :element-type '(unsigned-byte 8)
    81                                       :keep t)
    82              (typecase (buffer-memory-buffer buffer)
    83                (null-concatenated-xsubseqs)
    84                (t (write-sequence (coerce-to-sequence (buffer-memory-buffer buffer)) stream)))
    85              tmp)
    86            (buffer-on-memory-p buffer) nil
    87            (buffer-memory-buffer buffer) nil))
    88     ((and (not (buffer-on-memory-p buffer))
    89           (< (buffer-disk-limit buffer)
    90              (buffer-current-len buffer)))
    91      (error 'buffer-limit-exceeded :limit (buffer-disk-limit buffer)))))
    92 
    93 (defun finalize-buffer (buffer)
    94   (if (buffer-on-memory-p buffer)
    95       (flexi-streams:make-in-memory-input-stream
    96        (typecase (buffer-memory-buffer buffer)
    97          (null-concatenated-xsubseqs #())
    98          (t (coerce-to-sequence (buffer-memory-buffer buffer)))))
    99       (open (buffer-disk-buffer buffer) :direction :input :element-type '(unsigned-byte 8))))
   100 
   101 (defmacro with-smart-buffer ((buffer &key
   102                                        (memory-limit '*default-memory-limit*)
   103                                        (disk-limit '*default-disk-limit*))
   104                              &body body)
   105   `(let ((,buffer (make-smart-buffer :memory-limit ,memory-limit :disk-limit ,disk-limit)))
   106      ,@body
   107      (finalize-buffer ,buffer)))
   108 
   109 (defun delete-stream-file (stream)
   110   (when (typep stream 'file-stream)
   111     (ignore-errors (delete-file (pathname stream))))
   112   (values))
   113 
   114 (defun delete-temporary-files (&key (stale-seconds 0))
   115   (let ((now (get-universal-time)))
   116     (mapc #'uiop:delete-file-if-exists
   117           (remove-if-not (lambda (file)
   118                            (< stale-seconds (- now (file-write-date file))))
   119                          (uiop:directory-files *temporary-directory*)))))