← Back to branch summary

~ubuntu-branches/ubuntu/jaunty/electric/jaunty

« back to all changes in this revision

Viewing changes to lib/lisp/unix.scm

  • Committer: Bazaar Package Importer
  • Author(s): Onkar Shinde
  • Date: 2009-01-08 02:05:08 UTC
  • mfrom: (1.3.1 upstream) (3.1.3 sid)
  • mto: (3.1.4 sid)
  • mto: This revision was merged to the branch mainline in revision 11.
  • Revision ID: james.westby@ubuntu.com-20090108020508-3e7e6241i7bkit2l
New upstream version.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/lisp/unix.scm
1
 
;;; -*-Scheme-*-
2
 
;;;
3
 
;;; The Scheme layer of the UNIX extension.
4
 
 
5
 
(require 'record)
6
 
(require 'recordutil)
7
 
(require 'unix.o)
8
 
 
9
 
(define-record-type stat (type mode ino dev nlink uid gid size
10
 
                          atime mtime ctime))
11
 
(define-record-accessors stat-record)
12
 
 
13
 
(define (unix-stat fn)
14
 
  (let* ((ret (make-stat-record))
15
 
         (err (unix-stat-vector-fill! fn (record-values ret))))
16
 
    (if (unix-error? err) err ret)))
17
 
 
18
 
(if (feature? 'unix:symlinks)
19
 
    (define (unix-lstat fn)
20
 
      (let* ((ret (make-stat-record))
21
 
             (err (unix-lstat-vector-fill! fn (record-values ret))))
22
 
        (if (unix-error? err) err ret))))
23
 
 
24
 
 
25
 
(define-record-type time (seconds minutes hours day-of-month month year
26
 
                          weekday day-of-year dst))
27
 
(define-record-accessors time-record)
28
 
(define-record-modifiers time-record)
29
 
 
30
 
(define (unix-decode-localtime t)
31
 
  (let ((ret (make-time-record)))
32
 
    (unix-decode-time-vector-fill! t (record-values ret) #f)
33
 
    ret))
34
 
 
35
 
(define (unix-decode-utc t)
36
 
  (let ((ret (make-time-record)))
37
 
    (unix-decode-time-vector-fill! t (record-values ret) #t)
38
 
    ret))
39
 
 
40
 
(define (unix-time->string t)
41
 
  (cond
42
 
    ((integer? t)
43
 
     (unix-time->string-internal t))
44
 
    ((time-record? t)
45
 
     (unix-time->string-internal (record-values t)))
46
 
    (else
47
 
     (error 'unix-time->string "argument must be integer or time-record"))))
48
 
 
49
 
 
50
 
(define-record-type nanotime (nanoseconds minuteswest dst))
51
 
(define-record-accessors nanotime-record)
52
 
 
53
 
(define (unix-internal-make-nanotime v i)
54
 
  (if (vector-ref v i)
55
 
      (vector-set! v i (+ (* (car (vector-ref v i)) 1000000000)
56
 
                          (cdr (vector-ref v i))))))
57
 
 
58
 
(define (unix-nanotime)
59
 
  (let* ((ret (make-nanotime-record))
60
 
         (v (record-values ret)))
61
 
    (unix-nanotime-vector-fill! v)
62
 
    (vector-set! v 0 (+ (* (car (vector-ref v 0)) 1000000000)
63
 
                        (cdr (vector-ref v 0))))
64
 
    ret))
65
 
 
66
 
 
67
 
(define-record-type system (hostname sysname osname))
68
 
(define-record-accessors system-record)
69
 
 
70
 
(define (unix-system-info)
71
 
  (let ((ret (make-system-record)))
72
 
    (unix-system-info-vector-fill! (record-values ret))
73
 
    ret))
74
 
 
75
 
 
76
 
(define-record-type passwd (name password uid gid gecos homedir shell))
77
 
(define-record-accessors passwd-record)
78
 
 
79
 
(define (unix-get-passwd . arg)
80
 
  (let* ((ret (make-passwd-record))
81
 
         (err (apply unix-get-passwd-vector-fill! (record-values ret) arg)))
82
 
    (if (unix-error? err) err ret)))
83
 
 
84
 
 
85
 
(define-record-type group (name password gid members))
86
 
(define-record-accessors group-record)
87
 
 
88
 
(define (unix-get-group . arg)
89
 
  (let* ((ret (make-group-record))
90
 
         (err (apply unix-get-group-vector-fill! (record-values ret) arg)))
91
 
    (if (unix-error? err) err ret)))
92
 
 
93
 
 
94
 
(define-record-type resources (user-time system-time))
95
 
(define-record-accessors resources-record)
96
 
 
97
 
(define (unix-process-resources)
98
 
  (let* ((self (make-resources-record))
99
 
         (children (make-resources-record))
100
 
         (v1 (record-values self))
101
 
         (v2 (record-values children))
102
 
         (ticks/s (unix-process-resources-vector-fill! v1 v2))
103
 
         (convert (lambda (ticks) (round (/ (* ticks 1000000000) ticks/s)))))
104
 
    (vector-set! v1 0 (convert (vector-ref v1 0)))
105
 
    (vector-set! v1 1 (convert (vector-ref v1 1)))
106
 
    (vector-set! v2 0 (convert (vector-ref v2 0)))
107
 
    (vector-set! v2 1 (convert (vector-ref v2 1)))
108
 
    (cons self children)))
109
 
 
110
 
 
111
 
(if (feature? 'unix:file-locking)
112
 
  (begin
113
 
    (define-record-type lock (exclusive? whence start length))
114
 
    (define-record-accessors lock-record)
115
 
    (define-record-modifiers lock-record)
116
 
 
117
 
    (define (unix-set-lock fd lock wait?)
118
 
      (if (not (lock-record? lock))
119
 
          (error 'unix-set-lock "argument not a lock-record"))
120
 
      (unix-internal-lock-operation fd (record-values lock) wait? #\s 0))
121
 
 
122
 
    (define (unix-remove-lock fd lock)
123
 
      (if (not (lock-record? lock))
124
 
          (error 'unix-remove-lock "argument not a lock-record"))
125
 
      (unix-internal-lock-operation fd (record-values lock) #f #\r 0))
126
 
 
127
 
    (define (unix-query-lock fd lock)
128
 
      (if (not (lock-record? lock))
129
 
          (error 'unix-remove-lock "argument not a lock-record"))
130
 
      (let* ((ret (make-lock-record))
131
 
             (pid (unix-internal-lock-operation fd (record-values lock)
132
 
                                                #f #\q (record-values ret))))
133
 
        (if pid
134
 
            (cons pid ret)
135
 
            #f)))))
136
 
 
137
 
 
138
 
(define-record-type wait (pid status code core-dump? resources))
139
 
(define-record-accessors wait-record)
140
 
 
141
 
(define (unix-wait . options)
142
 
  (let* ((ret (make-wait-record))
143
 
         (resources ((record-constructor resources-record) #f #f))
144
 
         (v (record-values ret))
145
 
         (rv (record-values resources))
146
 
         (err (apply unix-wait-vector-fill! v rv options)))
147
 
    (unix-internal-make-nanotime rv 0)
148
 
    (unix-internal-make-nanotime rv 1)
149
 
    (vector-set! v 4 resources)
150
 
    (if (unix-error? err) err ret)))
151
 
 
152
 
(if (feature? 'unix:wait-process)
153
 
    (define (unix-wait-process pid . options)
154
 
      (let* ((ret (make-wait-record))
155
 
             (resources ((record-constructor resources-record) #f #f))
156
 
             (v (record-values ret))
157
 
             (rv (record-values resources))
158
 
             (err (apply unix-wait-process-vector-fill! v rv pid options)))
159
 
        (unix-internal-make-nanotime rv 0)
160
 
        (unix-internal-make-nanotime rv 1)
161
 
        (vector-set! v 4 resources)
162
 
        (if (unix-error? err) err ret))))
163
 
      
164
 
 
165
 
(define (unix-perror str)
166
 
  (format #t "~a: ~E" str))
167
 
 
168
 
(define-macro (unix-errval expr)
169
 
  `(fluid-let ((unix-call-standard-error-handler? #f))
170
 
     ,expr))
171
 
 
172
 
;; also need the opposite of unix-errval (i.e. make sure error is handled)
173
 
 
174
 
(provide 'unix)