home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / unxprm.scm < prev    next >
Text File  |  2001-05-08  |  17KB  |  501 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: unxprm.scm,v 1.61 2001/05/09 03:17:14 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
  20. USA.
  21. |#
  22.  
  23. ;;;; Miscellaneous Unix Primitives
  24. ;;; package: ()
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (file-modes filename)
  29.   ((ucode-primitive file-modes 1) (->namestring (merge-pathnames filename))))
  30.  
  31. (define-integrable (set-file-modes! filename modes)
  32.   ((ucode-primitive set-file-modes! 2)
  33.    (->namestring (merge-pathnames filename))
  34.    modes))
  35.  
  36. (define unix/file-access file-access)    ;upwards compatability
  37.  
  38. (define (temporary-file-pathname #!optional directory)
  39.   (let ((root-string
  40.      (string-append
  41.       "sch"
  42.       (string-pad-left (number->string (unix/current-pid)) 6 #\0)
  43.       "_"))
  44.     (directory
  45.      (if (or (default-object? directory) (not directory))
  46.          (temporary-directory-pathname)
  47.          (pathname-as-directory directory))))
  48.     (let loop ((ext 0))
  49.       (let ((pathname
  50.          (merge-pathnames (string-append root-string (number->string ext))
  51.                   directory)))
  52.     (if (allocate-temporary-file pathname)
  53.         (begin
  54.           ;; Make sure file isn't readable or writeable by anyone
  55.           ;; other than the owner.
  56.           (set-file-modes! pathname
  57.                    (fix:and (file-modes pathname)
  58.                     #o0700))
  59.           pathname)
  60.         (begin
  61.           (if (> ext 999)
  62.           (error "Can't find unique temporary pathname:"
  63.              (merge-pathnames root-string directory)))
  64.           (loop (+ ext 1))))))))
  65.  
  66. (define (temporary-directory-pathname)
  67.   (let ((try-directory
  68.      (lambda (directory)
  69.        (let ((directory
  70.           (pathname-as-directory (merge-pathnames directory))))
  71.          (and (file-directory? directory)
  72.           (file-writeable? directory)
  73.           directory)))))
  74.     (let ((try-variable
  75.        (lambda (name)
  76.          (let ((value (get-environment-variable name)))
  77.            (and value
  78.             (try-directory value))))))
  79.       (or (try-variable "TMPDIR")
  80.       (try-variable "TEMP")
  81.       (try-variable "TMP")
  82.       (try-directory "/var/tmp")
  83.       (try-directory "/usr/tmp")
  84.       (try-directory "/tmp")
  85.       (error "Can't find temporary directory.")))))
  86.  
  87. (define (file-attributes-direct filename)
  88.   ((ucode-primitive file-attributes 1)
  89.    (->namestring (merge-pathnames filename))))
  90.  
  91. (define (file-attributes-indirect filename)
  92.   ((ucode-primitive file-attributes-indirect 1)
  93.    (->namestring (merge-pathnames filename))))
  94.  
  95. (define file-attributes
  96.   file-attributes-direct)
  97.  
  98. (define-structure (file-attributes
  99.            (type vector)
  100.            (constructor false)
  101.            (conc-name file-attributes/))
  102.   (type false read-only true)
  103.   (n-links false read-only true)
  104.   (uid false read-only true)
  105.   (gid false read-only true)
  106.   (access-time false read-only true)
  107.   (modification-time false read-only true)
  108.   (change-time false read-only true)
  109.   (length false read-only true)
  110.   (mode-string false read-only true)
  111.   (inode-number false read-only true))
  112.  
  113. (define (file-length filename)
  114.   (file-attributes/length (file-attributes-direct filename)))
  115.  
  116. (define (file-modification-time-direct filename)
  117.   ((ucode-primitive file-mod-time 1)
  118.    (->namestring (merge-pathnames filename))))
  119.  
  120. (define (file-modification-time-indirect filename)
  121.   ((ucode-primitive file-mod-time-indirect 1)
  122.    (->namestring (merge-pathnames filename))))
  123.  
  124. (define file-modification-time
  125.   file-modification-time-indirect)
  126.  
  127. (define (file-access-time-direct filename)
  128.   ((ucode-primitive file-access-time 1)
  129.    (->namestring (merge-pathnames filename))))
  130.  
  131. (define (file-access-time-indirect filename)
  132.   ((ucode-primitive file-access-time-indirect 1)
  133.    (->namestring (merge-pathnames filename))))
  134.  
  135. (define file-access-time
  136.   file-access-time-indirect)
  137.  
  138. (define (set-file-times! filename access-time modification-time)
  139.   (let ((filename (->namestring (merge-pathnames filename))))
  140.     ((ucode-primitive set-file-times! 3)
  141.      filename
  142.      (or access-time (file-access-time-direct filename))
  143.      (or modification-time (file-modification-time-direct filename)))))
  144.  
  145. (define get-environment-variable)
  146. (define set-environment-variable!)
  147. (define delete-environment-variable!)
  148. (define reset-environment-variables!)
  149.  
  150. (let ((environment-variables '()))
  151.   ;; Kludge: since getenv returns false for unbound,
  152.   ;; that can also be the marker for a deleted variable
  153.   (define-integrable *variable-deleted* false)
  154.  
  155.   (set! get-environment-variable
  156.     (lambda (variable)
  157.       (cond ((not (string? variable))
  158.          (error "GET-ENVIRONMENT-VARIABLE: Variable must be a string"
  159.             variable))
  160.         ((assoc variable environment-variables)
  161.          =>
  162.          cdr)
  163.         (else ((ucode-primitive get-environment-variable 1)
  164.                variable)))))
  165.  
  166.   (set! set-environment-variable!
  167.     (lambda (variable value)
  168.       (cond ((not (string? variable))
  169.          (error "SET-ENVIRONMENT-VARIABLE!: Variable must be a string"
  170.             variable value))
  171.         ((assoc variable environment-variables)
  172.          =>
  173.          (lambda (pair)
  174.            (set-cdr! pair value)))
  175.         (else
  176.          (set! environment-variables
  177.                (cons (cons variable value)
  178.                  environment-variables))))
  179.       unspecific))
  180.  
  181.   (set! delete-environment-variable!
  182.     (lambda (variable)
  183.       (set-environment-variable! variable *variable-deleted*)))
  184.  
  185.   (set! reset-environment-variables!
  186.     (lambda () (set! environment-variables '())))
  187. ) ; End LET
  188.  
  189. (define (user-home-directory user-name)
  190.   (let ((directory ((ucode-primitive get-user-home-directory 1) user-name)))
  191.     (if (not directory)
  192.     (error "Can't find user's home directory:" user-name))
  193.     (pathname-as-directory directory)))
  194.  
  195. (define (current-home-directory)
  196.   (let ((home (get-environment-variable "HOME")))
  197.     (if home
  198.     (pathname-as-directory home)
  199.     (user-home-directory (current-user-name)))))
  200.  
  201. (define (current-user-name)
  202.   (or (get-environment-variable "USER")
  203.       ((ucode-primitive current-user-name 0))))
  204.  
  205. (define (file-time->local-decoded-time time)
  206.   (universal-time->local-decoded-time (file-time->universal-time time)))
  207.  
  208. (define (file-time->global-decoded-time time)
  209.   (universal-time->global-decoded-time (file-time->universal-time time)))
  210.  
  211. (define (decoded-time->file-time dt)
  212.   (universal-time->file-time (decoded-time->universal-time dt)))
  213.  
  214. (define (file-time->universal-time time) (+ time epoch))
  215. (define (universal-time->file-time time) (- time epoch))
  216.  
  217. (define decode-file-time file-time->local-decoded-time)
  218. (define encode-file-time decoded-time->file-time)
  219. (define unix/user-home-directory user-home-directory)
  220. (define unix/current-home-directory current-home-directory)
  221. (define unix/current-user-name current-user-name)
  222.  
  223. (define-integrable unix/current-uid (ucode-primitive current-uid 0))
  224. (define-integrable unix/current-gid (ucode-primitive current-gid 0))
  225. (define-integrable unix/current-pid (ucode-primitive current-pid 0))
  226.  
  227. (define (unix/uid->string uid)
  228.   (or ((ucode-primitive uid->string 1) uid)
  229.       (number->string uid 10)))
  230.  
  231. (define (unix/gid->string gid)
  232.   (or ((ucode-primitive gid->string 1) gid)
  233.       (number->string gid 10)))
  234.  
  235. (define (unix/system string)
  236.   (let ((wd-inside (->namestring (working-directory-pathname)))
  237.     (wd-outside)
  238.     (ti-outside))
  239.     (dynamic-wind
  240.      (lambda ()
  241.        (set! wd-outside ((ucode-primitive working-directory-pathname 0)))
  242.        ((ucode-primitive set-working-directory-pathname! 1) wd-inside)
  243.        (set! ti-outside (thread-timer-interval))
  244.        (set-thread-timer-interval! #f))
  245.      (lambda ()
  246.        ((ucode-primitive system 1) string))
  247.      (lambda ()
  248.        ((ucode-primitive set-working-directory-pathname! 1) wd-outside)
  249.        (set! wd-outside)
  250.        (set-thread-timer-interval! ti-outside)
  251.        (set! ti-outside)
  252.        unspecific))))
  253.  
  254. (define (os/file-end-of-line-translation pathname)
  255.   ;; This works because the line translation is harmless when not
  256.   ;; needed.  We can't tell when it is needed, because FAT and HPFS
  257.   ;; filesystems can be mounted with automatic translation (in the
  258.   ;; Linux kernel), and ISO9660 can be either DOS or unix format.
  259.   (let ((type
  260.      ((ucode-primitive file-system-type 1)
  261.       (->namestring
  262.        (let loop ((pathname (merge-pathnames pathname)))
  263.          (if (file-exists? pathname)
  264.          pathname
  265.          (loop (directory-pathname-as-file
  266.             (directory-pathname pathname)))))))))
  267.     (if (or (string-ci=? "fat" type)
  268.         (string-ci=? "hpfs" type)
  269.         (string-ci=? "iso9660" type)
  270.         (string-ci=? "ntfs" type)
  271.         (string-ci=? "smb" type))
  272.     "\r\n"
  273.     #f)))
  274.  
  275. (define (os/default-end-of-line-translation)
  276.   #f)
  277.  
  278. (define (copy-file from to)
  279.   (let ((input-filename (->namestring (merge-pathnames from)))
  280.     (output-filename (->namestring (merge-pathnames to))))
  281.     (let ((input-channel false)
  282.       (output-channel false))
  283.       (dynamic-wind
  284.        (lambda ()
  285.      (set! input-channel (file-open-input-channel input-filename))
  286.      (set! output-channel (file-open-output-channel output-filename))
  287.      unspecific)
  288.        (lambda ()
  289.      (let ((source-length (channel-file-length input-channel))
  290.            (buffer-length 8192))
  291.        (if (zero? source-length)
  292.            0
  293.            (let* ((buffer (make-string buffer-length))
  294.               (transfer
  295.                (lambda (length)
  296.              (let ((n-read
  297.                 (channel-read-block input-channel
  298.                             buffer
  299.                             0
  300.                             length)))
  301.                (if (positive? n-read)
  302.                    (channel-write-block output-channel
  303.                             buffer
  304.                             0
  305.                             n-read))
  306.                n-read))))
  307.          (let loop ((source-length source-length))
  308.            (if (< source-length buffer-length)
  309.                (transfer source-length)
  310.                (let ((n-read (transfer buffer-length)))
  311.              (if (= n-read buffer-length)
  312.                  (+ (loop (- source-length buffer-length))
  313.                 buffer-length)
  314.                  n-read))))))))
  315.        (lambda ()
  316.      (if output-channel (channel-close output-channel))
  317.      (if input-channel (channel-close input-channel)))))
  318.     (set-file-times! output-filename
  319.              #f
  320.              (file-modification-time input-filename))
  321.     (set-file-modes! output-filename (file-modes input-filename))))
  322.  
  323. (define (init-file-specifier->pathname specifier)
  324.   (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME)
  325.   (merge-pathnames (apply string-append
  326.               (cons ".mit-scheme"
  327.                 (append-map (lambda (string) (list "/" string))
  328.                         specifier)))
  329.            (user-homedir-pathname)))
  330.  
  331. ;;; Queues after-restart daemon to clean up environment space
  332.  
  333. (define (initialize-system-primitives!)
  334.   (add-event-receiver! event:after-restart reset-environment-variables!)
  335.   (discard-select-registry-result-vectors!)
  336.   (add-event-receiver! event:after-restart
  337.                discard-select-registry-result-vectors!))
  338.  
  339. (define (make-select-registry . descriptors)
  340.   (let ((registry (make-string ((ucode-primitive select-registry-size 0)))))
  341.     ((ucode-primitive select-registry-clear-all 1) registry)
  342.     (do ((descriptors descriptors (cdr descriptors)))
  343.     ((null? descriptors))
  344.       ((ucode-primitive select-registry-set 2) registry (car descriptors)))
  345.     registry))
  346.  
  347. (define (add-to-select-registry! registry descriptor)
  348.   ((ucode-primitive select-registry-set 2) registry descriptor))
  349.  
  350. (define (remove-from-select-registry! registry descriptor)
  351.   ((ucode-primitive select-registry-clear 2) registry descriptor))
  352.  
  353. (define (select-descriptor descriptor block?)
  354.   (let ((result ((ucode-primitive select-descriptor 2) descriptor block?)))
  355.     (case result
  356.       ((0)
  357.        #f)
  358.       ((1)
  359.        'INPUT-AVAILABLE)
  360.       ((-1)
  361.        (subprocess-global-status-tick)
  362.        'PROCESS-STATUS-CHANGE)
  363.       ((-2)
  364.        'INTERRUPT)
  365.       (else
  366.        (error "Illegal result from CHANNEL-SELECT:" result)))))
  367.  
  368. (define (select-registry-test registry block?)
  369.   (let ((result-vector (allocate-select-registry-result-vector)))
  370.     (let ((result
  371.        ((ucode-primitive select-registry-test 3) registry block?
  372.                              result-vector)))
  373.       (if (fix:> result 0)
  374.       (let loop ((index (fix:- result 1)) (descriptors '()))
  375.         (let ((descriptors
  376.            (cons (vector-ref result-vector index) descriptors)))
  377.           (if (fix:= 0 index)
  378.           (begin
  379.             (deallocate-select-registry-result-vector result-vector)
  380.             descriptors)
  381.           (loop (fix:- index 1) descriptors))))
  382.       (begin
  383.         (deallocate-select-registry-result-vector result-vector)
  384.         (cond ((fix:= 0 result)
  385.            #f)
  386.           ((fix:= -1 result)
  387.            (subprocess-global-status-tick)
  388.            'PROCESS-STATUS-CHANGE)
  389.           ((fix:= -2 result)
  390.            'INTERRUPT)
  391.           (else
  392.            (error "Illegal result from SELECT-REGISTRY-TEST:"
  393.               result))))))))
  394.  
  395. (define select-registry-result-vectors)
  396.  
  397. (define (discard-select-registry-result-vectors!)
  398.   (set! select-registry-result-vectors '())
  399.   unspecific)
  400.  
  401. (define (allocate-select-registry-result-vector)
  402.   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
  403.     (let ((v
  404.        (let loop ((rv select-registry-result-vectors))
  405.          (cond ((null? rv)
  406.             (make-vector ((ucode-primitive select-registry-lub 0)) #f))
  407.            ((car rv)
  408.             => (lambda (v) (set-car! rv #f) v))
  409.            (else
  410.             (loop (cdr rv)))))))
  411.       (set-interrupt-enables! interrupt-mask)
  412.       v)))
  413.  
  414. (define (deallocate-select-registry-result-vector v)
  415.   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
  416.     (let loop ((rv select-registry-result-vectors))
  417.       (cond ((null? rv)
  418.          (set! select-registry-result-vectors
  419.            (cons v select-registry-result-vectors)))
  420.         ((car rv)
  421.          (loop (cdr rv)))
  422.         (else
  423.          (set-car! rv v))))
  424.     (set-interrupt-enables! interrupt-mask)))
  425.  
  426. ;;;; Subprocess/Shell Support
  427.  
  428. (define (os/make-subprocess filename arguments environment working-directory
  429.                 ctty stdin stdout stderr)
  430.   ((ucode-primitive ux-make-subprocess 8)
  431.    filename arguments environment working-directory
  432.    ctty stdin stdout stderr))
  433.  
  434. (define (os/find-program program default-directory #!optional exec-path error?)
  435.   (let ((namestring
  436.      (let ((exec-path
  437.         (if (default-object? exec-path)
  438.             (os/exec-path)
  439.             exec-path)))
  440.        (let ((try
  441.           (lambda (pathname)
  442.             (and (file-access pathname 1)
  443.              (->namestring pathname)))))
  444.          (cond ((pathname-absolute? program)
  445.             (try program))
  446.            ((not default-directory)
  447.             (let loop ((path exec-path))
  448.               (and (not (null? path))
  449.                (or (and (car path)
  450.                     (pathname-absolute? (car path))
  451.                     (try (merge-pathnames program (car path))))
  452.                    (loop (cdr path))))))
  453.            (else
  454.             (let ((default-directory
  455.                 (merge-pathnames default-directory)))
  456.               (let loop ((path exec-path))
  457.             (and (not (null? path))
  458.                  (or (try (merge-pathnames
  459.                        program
  460.                        (if (car path)
  461.                        (merge-pathnames (car path)
  462.                                 default-directory)
  463.                        default-directory)))
  464.                  (loop (cdr path))))))))))))
  465.     (if (and (not namestring)
  466.          (if (default-object? error) #t error?))
  467.     (error "Can't find program:" (->namestring program)))
  468.     namestring))
  469.  
  470. (define (os/exec-path)
  471.   (os/parse-path-string
  472.    (let ((path (get-environment-variable "PATH")))
  473.      (if (not path)
  474.      (error "Can't find PATH environment variable."))
  475.      path)))
  476.  
  477. (define (os/parse-path-string string)
  478.   (let ((end (string-length string))
  479.     (substring
  480.      (lambda (string start end)
  481.        (pathname-as-directory (substring string start end)))))
  482.     (let loop ((start 0))
  483.       (if (< start end)
  484.       (let ((index (substring-find-next-char string start end #\:)))
  485.         (if index
  486.         (cons (if (= index start)
  487.               false
  488.               (substring string start index))
  489.               (loop (+ index 1)))
  490.         (list (substring string start end))))
  491.       '()))))
  492.  
  493. (define (os/shell-file-name)
  494.   (or (get-environment-variable "SHELL")
  495.       "/bin/sh"))
  496.  
  497. (define (os/form-shell-command command)
  498.   (list "-c" command))
  499.  
  500. (define (os/executable-pathname-types)
  501.   '())