modules/zlib.lsp

   1 ;; @module zlisp.lsp
   2 ;; @description Functions for compression/decompression with zlib
   3 ;; @version 1.1 - comments redone for automatic documentation
   4 ;; @version 1.2 - new library detection routine
   5 ;; @author April 13th 2006, L.M.
   6 ;;
   7 ;; <h2>Functions for compression/decompression with zlib</h2>
   8 ;; For this module a platform sepcific library
   9 ;; from @link http://www.zlib.net/ www.zib.net is needed.
  10 ;;
  11 ;; The module offers two types of compression/decompression support:
  12 ;; one for fast in memory compression/decopmpression, the other for
  13 ;; GZ compatible file compression and decompression.
  14 ;;
  15 ;; Before using the module it must be loaded:
  16 ;; <pre>
  17 ;; (load "/usr/share/newlisp/modules/zlib.lsp")
  18 ;; </pre>
  19
  20
  21 (context 'zlib)
  22
  23 (set 'files '(
  24         "/usr/lib/libz.so" ; Linuyx and BSDs
  25         "/usr/lib/libz.dylib" ; Mac OSX / Darwin
  26         "/usr/lib/libz.so" ; Solaris
  27         "libz1.dll" ; Win32
  28 ))
  29
  30 (set 'library (files (or
  31                                 (find true (map file? files))
  32                                 (begin (println "cannot find zlib compression library") (exit)))))
  33
  34 (import library "compress")
  35 (import library "uncompress")
  36 (import library "gzopen")
  37 (import library "gzread")
  38 (import library "gzclose")
  39 (import library "gzwrite")
  40
  41 ;; @syntax (zlib:squeeze <str-buffer>)
  42 ;; @return The string containing the compressed <str-buffer>.
  43 ;; @example
  44 ;; (set 'str-z  (zlib:squeeze str))
  45
  46 (define (squeeze src)
  47         (letn ( (srclen (length src))
  48                         (destlen (int (add (mul 1.01 srclen) 12)))
  49                         (dest (dup "\000" destlen))
  50                         (destlenp (pack "ld" destlen))
  51                         )
  52         (compress dest destlenp src srclen)
  53         (set 'destlen (first (unpack "ld" destlenp)))
  54         (slice dest 0 destlen)))
  55
  56
  57 ;; @syntax (zlib:unsqueeze <str-buffer>)
  58 ;; @return The original uncompressed string from a compressed buffer in <str-buffer>
  59 ;; @example
  60 ;; (set 'str (zlib:unsqueeze str-z))
  61
  62 (define (unsqueeze src)
  63         (letn ( (srclen (length src))
  64                         (destlen (* srclen 3))
  65                         (dest (dup "\000" destlen))
  66                         (destlenp (pack "ld" destlen))
  67                         )
  68                 (while (= -5 (uncompress dest destlenp src srclen))
  69                         (set 'destlen (* 2 destlen))
  70                         (set 'dest (dup "\000" destlen))
  71                         (set 'destlenp (pack "ld" destlen)))
  72                 (set 'destlen (first (unpack "ld" destlenp)))
  73                 (slice dest 0 destlen)))
  74
  75 ;; @syntax (zlib:gz-read-file <str-file-name>)
  76 ;; @return A string buffer with the original contents.
  77 ;;
  78 ;; Uncompresses the GZ compressed file in <str-file-name>.
  79 ;; @example
  80 ;; (set 'buff (zlib:gz-read-file "myfile.gz"))
  81
  82 (define (gz-read-file file-name)
  83         (let ( (fno (gzopen file-name "rb"))
  84                (buff (dup "\000" 0x1000))
  85                (result ""))
  86                 (if (!= fno 0)
  87                         (begin
  88                                 (while (> (set 'bytes (gzread fno buff 0x1000)) 0)
  89                                         (write-buffer result buff bytes))
  90                                 (gzclose fno)
  91                                 result))))
  92
  93 ;; @syntax (zlib:gz-write-file <str-file-name> <str-buffer>)
  94 ;; @return The number of bytes in <str-buffer>.
  95 ;;
  96 ;; Does a GZ compatible comrpression of a buffer in <str-buffer> and
  97 ;; writes it to the file in <str-file-name>.
  98 ;; @example
  99 ;; (zlib:gz-write-file "myfile.gz" buff)
 100
 101 (define (gz-write-file file-name buff)
 102     (let ( (fno (gzopen file-name "wb"))
 103                    (result nil))
 104         (if (!= fno 0)
 105                         (begin
 106                                 (set 'result (gzwrite fno buff (length buff)))
 107                                 (gzclose fno)
 108                                 result))))
 109
 110 (context MAIN)
 111
 112 ; eof
 113