Re: [Chicken-users] I need some new eggs: posix-extensions and lzma

[Alaric Snell-Pym]

On 17 Jan 2009, at 10:57 pm, Kon Lovett wrote:
> Yes. The misc-extn egg needs to be "exploded". If you want I can
> create a "posix-extensions" (posix-extras, posix-extn, ?) with the
> current misc-extn-posix code & your S_IFMT additions.


That'd suit me fine. Here's what I've got. I based it on existing
stuff in the posix egg through blatant copying - I'm wondering about
recasting it in term of good clean foreign-lambdas rather than all
this ##core#inline stuff:

;; Things that the posix unit forgot
(foreign-declare #<<EOF

#include <sys/stat.h>
#include <utime.h>

double C_utime_atime;
double C_utime_mtime;
struct utimbuf C_utime_buf;

#define C_lchmod(fn, m)      C_fix(lchmod(C_data_pointer(fn),
C_unfix(m)))
#define C_lchown(fn, u, g)   C_fix(lchown(C_data_pointer(fn),
C_unfix(u), C_unfix(g)))
#define C_mknod(fn, m, d) C_fix(mknod(C_data_pointer(fn), C_unfix(m),
C_unfix(d)))
#define C_utime(fn) C_fix((C_utime_buf.actime = C_utime_atime,
C_utime_buf.modtime = C_utime_mtime, utime(C_data_pointer(fn),
&C_utime_buf)))
EOF
)

(define-foreign-variable _utime_atime double "C_utime_atime")
(define-foreign-variable _utime_mtime double "C_utime_mtime")

(define posix-error
  (let ([strerror (foreign-lambda c-string "strerror" int)]
        [string-append string-append] )
    (lambda (type loc msg . args)
      (let ([rn (##sys#update-errno)])
        (apply ##sys#signal-hook type loc (string-append msg " -
" (strerror rn)) args) ) ) ) )


(define-foreign-variable _s_ifmt int "S_IFMT")
(define stat/ifmt _s_ifmt)

(define-foreign-variable _s_ififo int "S_IFIFO")
(define stat/ififo _s_ififo)
(define-foreign-variable _s_ifchr int "S_IFCHR")
(define stat/ifchr _s_ifchr)
(define-foreign-variable _s_ifdir int "S_IFDIR")
(define stat/ifdir _s_ifdir)
(define-foreign-variable _s_ifblk int "S_IFBLK")
(define stat/ifblk _s_ifblk)
(define-foreign-variable _s_ifreg int "S_IFREG")
(define stat/ifreg _s_ifreg)
(define-foreign-variable _s_iflnk int "S_IFLNK")
(define stat/iflnk _s_iflnk)
(define-foreign-variable _s_ifsock int "S_IFSOCK")
(define stat/ifsock _s_ifsock)

(define change-link-mode
   (lambda (fname m)
      (##sys#check-string fname 'change-link-mode)
      (##sys#check-exact m 'change-link-mode)
      (when (fx< (##core#inline "C_lchmod" (##sys#make-c-string
(##sys#expand-home-path fname)) m) 0)
         (posix-error #:file-error 'change-link-mode "cannot change
link mode" fname m))))

(define change-link-owner
   (lambda (fn uid gid)
      (##sys#check-string fn 'change-link-owner)
      (##sys#check-exact uid 'change-link-owner)
      (##sys#check-exact gid 'change-link-owner)
      (when (fx< (##core#inline "C_lchown" (##sys#make-c-string
(##sys#expand-home-path fn)) uid gid) 0)
         (posix-error #:file-error 'change-link-owner "cannot change
link owner" fn uid gid))))

(define create-special-file
   (lambda (fn mode devnum)
      (##sys#check-string fn 'change-link-owner)
      (##sys#check-exact mode 'change-link-owner)
      (##sys#check-exact devnum 'change-link-owner)
      (when (fx< (##core#inline "C_mknod" (##sys#make-c-string
(##sys#expand-home-path fn)) mode devnum) 0)
         (posix-error #:file-error 'make-special-file "cannot make
special file" fn mode devnum))))

(define (change-file-times fn atime mtime)
   (##sys#check-string fn 'change-file-times)
   (##sys#check-number atime 'change-file-times)
   (##sys#check-number mtime 'change-file-times)

   (set! _utime_atime atime)
   (set! _utime_mtime mtime)

   (when (fx< (##core#inline "C_utime" (##sys#make-c-string
(##sys#expand-home-path fn))) 0)
      (posix-error #:file-error 'change-file-times "cannot change
file times" fn atime mtime)))



--
Alaric Snell-Pym
Work: http://www.snell-systems.co.uk/
Play: http://www.snell-pym.org.uk/alaric/
Blog: http://www.snell-pym.org.uk/?author=4