cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

zip.lisp (3298B)

      1 ;;; Copyright (C) 2014 Tomas Hlavaty <tom@logand.com>
      2 ;;;
      3 ;;; Permission is hereby granted, free of charge, to any person
      4 ;;; obtaining a copy of this software and associated documentation
      5 ;;; files (the "Software"), to deal in the Software without
      6 ;;; restriction, including without limitation the rights to use, copy,
      7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
      8 ;;; of the Software, and to permit persons to whom the Software is
      9 ;;; furnished to do so, subject to the following conditions:
     10 ;;;
     11 ;;; The above copyright notice and this permission notice shall be
     12 ;;; included in all copies or substantial portions of the Software.
     13 ;;;
     14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
     20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     21 ;;; DEALINGS IN THE SOFTWARE.
     22 
     23 (defpackage :rw.zip
     24   (:use :cl)
     25   (:export :unzip
     26            :with-unzip
     27            :zip))
     28 
     29 (in-package :rw.zip)
     30 
     31 (defstruct entry length method size cmpr date time crc32 name)
     32 
     33 (defun unzip (zip-file)
     34   (rw.os:with-program-output (s "unzip" (list "-v" (namestring zip-file)))
     35     (let ((r (rw:peek-reader (rw:char-reader s))))
     36       (rw:till r '(#\newline #\return))
     37       (rw:skip r)
     38       (rw:till r '(#\newline #\return))
     39       (rw:skip r)
     40       (rw:till r '(#\newline #\return))
     41       (rw:skip r)
     42       (prog1
     43           (loop
     44              until (eql #\- (rw:peek r))
     45              collect (make-entry :length (prog1 (rw:next-z0 r)
     46                                            (rw:skip r))
     47                                  :method (prog1 (rw:till r '(#\space))
     48                                            (rw:skip r))
     49                                  :size (prog1 (rw:next-z0 r)
     50                                          (rw:skip r))
     51                                  :cmpr (prog1 (rw:till r '(#\space))
     52                                          (rw:skip r))
     53                                  :date (prog1 (rw:till r '(#\space))
     54                                          (rw:skip r))
     55                                  :time (prog1 (rw:till r '(#\space))
     56                                          (rw:skip r))
     57                                  :crc32 (prog1 (rw:till r '(#\space))
     58                                           (rw:skip r))
     59                                  :name (coerce (prog1 (rw:till r '(#\newline #\return))
     60                                                  (rw:skip r))
     61                                                'string)))
     62         (rw:till r)))))
     63 
     64 (defun call-with-unzip (zip-file entry-name fn)
     65   (rw.os:with-program-output (s "unzip" (list "-p" (namestring zip-file) entry-name))
     66     (funcall fn s)))
     67 
     68 (defmacro with-unzip ((stream zip-file entry-name) &body body)
     69   `(call-with-unzip ,zip-file ,entry-name (lambda (,stream) ,@body)))
     70 
     71 (defun zip (zip-file &rest pathnames)
     72   (rw.os:with-program-output (s "zip" `("-r" ,@(mapcar #'namestring pathnames)))
     73     (let ((r (rw:peek-reader (rw:char-reader s))))
     74       (rw:till r))))