binary-filenames.scm 2.9 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283
  1. ;;; Disarchive
  2. ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
  3. ;;;
  4. ;;; This file is part of Disarchive.
  5. ;;;
  6. ;;; Disarchive is free software: you can redistribute it and/or modify
  7. ;;; it under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation, either version 3 of the License, or
  9. ;;; (at your option) any later version.
  10. ;;;
  11. ;;; Disarchive is distributed in the hope that it will be useful,
  12. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Disarchive. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (disarchive binary-filenames)
  19. #:use-module (disarchive config)
  20. #:use-module (rnrs bytevectors)
  21. #:use-module (system foreign)
  22. #:export (lstat/binary
  23. lstat/utf8
  24. open-input-file/binary
  25. open-input-file/utf8))
  26. ;;; Commentary:
  27. ;;;
  28. ;;; This module enables opening files with binary filenames. Normally
  29. ;;; Guile uses the current locale to encode strings before treating
  30. ;;; them as filenames. This module avoids this by calling 'open' from
  31. ;;; Libc directly, making use of either 'bytevector->pointer' or the
  32. ;;; 'encoding' parameter of 'string->pointer'.
  33. ;;;
  34. ;;; Code:
  35. (define libc (dynamic-link))
  36. (define %open
  37. (let* ((fptr (dynamic-func "open" libc))
  38. (f (pointer->procedure int fptr `(* ,int ,unsigned-int)
  39. #:return-errno? #t)))
  40. (lambda (filename pointer flags mode)
  41. (call-with-values
  42. (lambda ()
  43. (f pointer flags mode))
  44. (lambda (result errno)
  45. (unless (> result -1)
  46. (scm-error 'system-error '%open "~A: ~S"
  47. (list (strerror errno) filename)
  48. (list errno)))
  49. result)))))
  50. (define (binary-string->pointer bv)
  51. (let ((bvz (make-bytevector (1+ (bytevector-length bv)) 0)))
  52. (bytevector-copy! bv 0 bv 0 (bytevector-length bv))
  53. bvz))
  54. (define (lstat/pointer filename pointer)
  55. (let* ((fd (%open filename pointer (logior O_RDONLY O_NOFOLLOW) 0))
  56. (st (stat fd)))
  57. (close-fdes fd)
  58. st))
  59. (define (lstat/binary filename)
  60. (lstat/pointer filename (binary-string->pointer filename)))
  61. (define (lstat/utf8 filename)
  62. (lstat/pointer filename (string->pointer filename "UTF-8")))
  63. (define* (open-input-file/pointer filename pointer #:key binary?)
  64. (let ((fd (%open filename pointer O_RDONLY 0)))
  65. (fdopen fd (if binary? "rb" "r"))))
  66. (define* (open-input-file/binary filename #:key binary?)
  67. (open-input-file/pointer filename (binary-string->pointer filename)
  68. #:binary? binary?))
  69. (define* (open-input-file/utf8 filename #:key binary?)
  70. (open-input-file/pointer filename (string->pointer filename "UTF-8")
  71. #:binary? binary?))