public
Last active

file(1) wrapper, for newLISP

  • Download Gist
gistfile1.sls
Scheme
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
;; @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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.