file(1) wrapper, for newLISP

gistfile1.sls

;; @module libmagic.lsp
;; @description determine file type (use magic library)
;; @author KOBAYASHI Shigeru (kosh) <shigeru.kb@gmail.com>
;; @version 0.2

;;; Usage:

;; (load "libmagic.lsp")
;; (Magic:magic-file "libmagic.lsp")
;; => "Lisp/Scheme program text"
;; (Magic:magic-file Magic:libmagic)
;; => "PE32 executable for MS Windows (DLL) (console) Intel 80386 32-bit"
;; (Magic:magic-file Magic:magic-database)
;; => "magic binary file for file(1) cmd (version 7) (little endian)"
;; (Magic:magic-file Magic:magic-database true)
;; => "application/octet-stream; charset=binary"
;;
;; (Magic:magic-buffer (read-file "/usr/bin/newlispdoc"))
;; => "a /usr/bin/newlisp script text executable"

;;; ChangeLog:
;; 2010-01-09 初版
;; 2010-04-07 ファイルが存在しない場合はnewLISP側がエラーを投げるように変更

;;; Code:

(context 'Magic)

;;; NOTE: File for Windows - http://gnuwin32.sourceforge.net/packages/file.htm
(case ostype
  ("Win32"
   (define libmagic "C:/Program Files/GnuWin32/bin/magic1.dll")
   (define magic-database "C:/Program Files/GnuWin32/share/misc/magic.mgc")
   ;; `file' requires `regex' (and `zlib')
   (define libregex "C:/Program Files/GnuWin32/bin/regex2.dll")
   (import libregex "regcomp")
   (import libregex "regexec")
   (import libregex "regerror")
   (import libregex "regfree")
   )
  (true
   (define libmagic "libmagic.so.1")
   (define magic-database "/usr/share/file/magic.mgc") ; or "/etc/magic"
   ))

(import libmagic "magic_open")
(import libmagic "magic_close")

(import libmagic "magic_file")
(import libmagic "magic_descriptor")
(import libmagic "magic_buffer")

(import libmagic "magic_error")
(import libmagic "magic_setflags")

(import libmagic "magic_load")
(import libmagic "magic_compile")
(import libmagic "magic_check")
(import libmagic "magic_errno")

(define MAGIC_NONE              0x000000)
(define MAGIC_DEBUG             0x000001)
(define MAGIC_SYMLINK           0x000002)
(define MAGIC_COMPRESS          0x000004)
(define MAGIC_DEVICES           0x000008)
(define MAGIC_MIME_TYPE         0x000010)
(define MAGIC_CONTINUE          0x000020)
(define MAGIC_CHECK             0x000040)
(define MAGIC_PRESERVE_ATIME    0x000080)
(define MAGIC_RAW               0x000100)
(define MAGIC_ERROR             0x000200)
(define MAGIC_MIME_ENCODING     0x000400)
(define MAGIC_MIME              (| MAGIC_MIME_TYPE MAGIC_MIME_ENCODING))
(define MAGIC_APPLE             0x000800)
(define MAGIC_NO_CHECK_COMPRESS 0x001000)
(define MAGIC_NO_CHECK_TAR      0x002000)
(define MAGIC_NO_CHECK_SOFT     0x004000)
(define MAGIC_NO_CHECK_APPTYPE  0x008000)
(define MAGIC_NO_CHECK_ELF      0x010000)
(define MAGIC_NO_CHECK_TEXT     0x020000)
(define MAGIC_NO_CHECK_CDF      0x040000)
(define MAGIC_NO_CHECK_TOKENS   0x100000)
(define MAGIC_NO_CHECK_ENCODING 0x200000)

(define MAGIC_NO_CHECK_ASCII    MAGIC_NO_CHECK_TEXT)

(define MAGIC_NO_CHECK_FORTRAN  0x000000)
(define MAGIC_NO_CHECK_TROFF    0x000000)

(define NULL 0x00)


(setf magic-flags MAGIC_NONE)

(define (error )
  (throw-error (apply format (args))))

(letex ((result (sym (uuid))))
(define-macro (unwind-protect )
  (local (result)
    (if (catch (eval (args 0)) 'result)
        (begin (map eval (1 (args))) result)
      (begin (map eval (1 (args))) (throw-error (5 result))))))
)

(define (call-with-magic proc)
  (unless (lambda? proc)
    (error "function required: %s" (string proc)))
  (let ((cookie (magic_open (or magic-flags MAGIC_NONE))))
    (if (= cookie NULL)
        (error "magic_open: %s" (nth 1 (sys-error)))
      (unwind-protect
          (if (= (magic_load cookie magic-database) -1)
              (error "magic_load: %s" (get-string (magic_error cookie)))
            (let ((addr (proc cookie)))
              (if (= addr NULL)
                  (error "magic_file: %s" (get-string (magic_error cookie)))
                (get-string addr))))
        (if (!= cookie NULL)
            (magic_close cookie))))))

;;;###autoload
(define (magic-file filename (mime nil))
  ;(setq filename (real-path filename))
  (unless (file? filename)
    (error "cannot open `%s' (No such file or directory)" filename))
  (let ((magic-flags (| (if mime MAGIC_MIME 0)
                        (or magic-flags 0))))
    (call-with-magic (lambda (c)
                       (magic_file c filename)))))

;;;###autoload
(define (magic-buffer str (mime nil))
  (let ((magic-flags (| (if mime MAGIC_MIME 0)
                        (or magic-flags 0))))
    (call-with-magic (lambda (c)
                       (magic_buffer c str (length str))))))

(context MAIN)
;;; EOF