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 / dosprm.scm < prev    next >
Text File  |  2000-01-04  |  16KB  |  491 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: dosprm.scm,v 1.43 2000/01/05 02:40:31 cph Exp $
  4.  
  5. Copyright (c) 1992-2000 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Miscellaneous DOS Primitives (emulation of unxprm version 1.16)
  23. ;;; package: ()
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (file-directory? filename)
  28.   ((ucode-primitive file-directory? 1)
  29.    (->namestring (merge-pathnames filename))))
  30.  
  31. (define (file-symbolic-link? filename)
  32.   filename                ; ignored
  33.   false)
  34.  
  35. (define (file-modes filename)
  36.   ((ucode-primitive file-modes 1)
  37.    (->namestring (merge-pathnames filename))))
  38.  
  39. (define (set-file-modes! filename modes)
  40.   ((ucode-primitive set-file-modes! 2)
  41.    (->namestring (merge-pathnames filename))
  42.    modes))
  43.  
  44. (define (file-access filename amode)
  45.   ((ucode-primitive file-access 2)
  46.    (->namestring (merge-pathnames filename))
  47.    amode))
  48. ;; upwards compatability
  49. (define dos/file-access file-access)
  50.  
  51. (define (file-readable? filename)
  52.   (file-access filename 4))
  53.  
  54. (define (file-writeable? filename)
  55.   (let ((pathname (merge-pathnames filename)))
  56.     (let ((filename (->namestring pathname)))
  57.       (or ((ucode-primitive file-access 2) filename 2)
  58.       (and (not ((ucode-primitive file-exists? 1) filename))
  59.            ((ucode-primitive file-access 2)
  60.         (directory-namestring pathname)
  61.         2))))))
  62. ;; upwards compatability
  63. (define file-writable? file-writeable?)
  64.  
  65. (define (temporary-file-pathname #!optional directory)
  66.   (let ((root
  67.      (merge-pathnames "_scm_tmp"
  68.               (if (or (default-object? directory) (not directory))
  69.                   (temporary-directory-pathname)
  70.                   (pathname-as-directory directory)))))
  71.     (let loop ((ext 0))
  72.       (let ((pathname (pathname-new-type root (number->string ext))))
  73.     (if (allocate-temporary-file pathname)
  74.         pathname
  75.         (begin
  76.           (if (> ext 999)
  77.           (error "Can't find unique temporary pathname:" root))
  78.           (loop (+ ext 1))))))))
  79.  
  80. (define (temporary-directory-pathname)
  81.   (let ((try-directory
  82.      (lambda (directory)
  83.        (let ((directory
  84.           (pathname-as-directory (merge-pathnames directory))))
  85.          (and (file-directory? directory)
  86.           (file-writeable? directory)
  87.           directory)))))
  88.     (let ((try-variable
  89.        (lambda (name)
  90.          (let ((value (get-environment-variable name)))
  91.            (and value
  92.             (try-directory value))))))
  93.       (or (try-variable "TEMP")
  94.       (try-variable "TMP")
  95.       (try-directory "/tmp")
  96.       (try-directory "c:/")
  97.       (try-directory ".")
  98.       (try-directory "/")
  99.       (error "Can't find temporary directory.")))))
  100.  
  101. (define (file-attributes filename)
  102.   ((ucode-primitive file-attributes 1)
  103.    (->namestring (merge-pathnames filename))))
  104.  
  105. (define file-attributes-direct
  106.   file-attributes)
  107.  
  108. (define file-attributes-indirect
  109.   file-attributes)
  110.  
  111. (define-structure (file-attributes
  112.            (type vector)
  113.            (constructor false)
  114.            (conc-name file-attributes/))
  115.   (type false read-only true)
  116.   (n-links false read-only true)
  117.   (uid false read-only true)
  118.   (gid false read-only true)
  119.   (access-time false read-only true)
  120.   (modification-time false read-only true)
  121.   (change-time false read-only true)
  122.   (length false read-only true)
  123.   (mode-string false read-only true)
  124.   (inode-number false read-only true))
  125.  
  126. (define (file-length filename)
  127.   (file-attributes/length (file-attributes filename)))
  128.  
  129. (define (file-modification-time filename)
  130.   ((ucode-primitive file-mod-time 1)
  131.    (->namestring (merge-pathnames filename))))
  132.  
  133. (define file-modification-time-direct
  134.   file-modification-time)
  135.  
  136. (define file-modification-time-indirect
  137.   file-modification-time)
  138.  
  139. ;; These are obviously incorrect, but there is no alternative.
  140. ;; DOS only keeps track of modification times.
  141.  
  142. (define file-access-time-direct
  143.   file-modification-time-direct)
  144.  
  145. (define file-access-time-indirect
  146.   file-modification-time-indirect)
  147.  
  148. (define file-access-time
  149.   file-modification-time)
  150.  
  151. (define (set-file-times! filename access-time modification-time)
  152.   (let ((filename (->namestring (merge-pathnames filename)))
  153.     (time (or modification-time
  154.           access-time
  155.           (file-modification-time-direct filename))))
  156.     ((ucode-primitive set-file-times! 3)
  157.      filename
  158.      (or access-time time)
  159.      (or modification-time time))))
  160.  
  161. (define get-environment-variable)
  162. (define set-environment-variable!)
  163. (define set-environment-variable-default!)
  164. (define delete-environment-variable!)
  165. (define reset-environment-variables!)
  166. (let ((environment-variables '())
  167.       (environment-defaults '()))
  168.  
  169.   ;; Kludge: since getenv returns false for unbound,
  170.   ;; that can also be the marker for a deleted variable
  171.   (define-integrable *variable-deleted* false)
  172.  
  173.   (define (env-error proc var)
  174.     (error "Variable must be a string:" var proc))
  175.  
  176.   (define (default-variable! var val)
  177.     (if (and (not (assoc var environment-variables))
  178.          (not ((ucode-primitive get-environment-variable 1) var)))
  179.     (set! environment-variables
  180.           (cons (cons var (if (procedure? val) (val) val))
  181.             environment-variables)))
  182.     unspecific)
  183.  
  184.   (set! get-environment-variable
  185.     (lambda (variable)
  186.       (if (not (string? variable))
  187.           (env-error 'GET-ENVIRONMENT-VARIABLE variable))
  188.       (let ((variable (string-upcase variable)))
  189.         (cond ((assoc variable environment-variables)
  190.            => cdr)
  191.           (else
  192.            ((ucode-primitive get-environment-variable 1) variable))))))
  193.  
  194.   (set! set-environment-variable!
  195.     (lambda (variable value)
  196.       (if (not (string? variable))
  197.           (env-error 'SET-ENVIRONMENT-VARIABLE! variable))
  198.       (let ((variable (string-upcase variable)))
  199.         (cond ((assoc variable environment-variables)
  200.            => (lambda (pair) (set-cdr! pair value)))
  201.           (else
  202.            (set! environment-variables
  203.              (cons (cons variable value) environment-variables)))))
  204.       unspecific))
  205.  
  206.   (set! delete-environment-variable!
  207.     (lambda (variable)
  208.       (if (not (string? variable))
  209.           (env-error 'DELETE-ENVIRONMENT-VARIABLE! variable))
  210.       (set-environment-variable! variable *variable-deleted*)))
  211.  
  212.   (set! reset-environment-variables!
  213.     (lambda ()
  214.       (set! environment-variables '())
  215.       (for-each (lambda (def) (default-variable! (car def) (cdr def)))
  216.             environment-defaults)))
  217.  
  218.   (set! set-environment-variable-default!
  219.     (lambda (var val)
  220.       (if (not (string? var))
  221.           (env-error 'SET-ENVIRONMENT-VARIABLE-DEFAULT! var))
  222.       (let ((var (string-upcase var)))
  223.         (cond ((assoc var environment-defaults)
  224.            => (lambda (pair) (set-cdr! pair val)))
  225.           (else
  226.            (set! environment-defaults
  227.              (cons (cons var val) environment-defaults))))
  228.         (default-variable! var val))))
  229.  
  230. )                ; End LET
  231.  
  232. (define (current-home-directory)
  233.   (let ((home (get-environment-variable "HOME")))
  234.     (if home
  235.     (pathname-as-directory (merge-pathnames home))
  236.     (user-home-directory (current-user-name)))))
  237.  
  238. (define (current-user-name)
  239.   (or (get-environment-variable "USER")
  240.       "nouser"))
  241.  
  242. (define (user-home-directory user-name)
  243.   (or (and user-name
  244.        (let ((directory (get-environment-variable "USERDIR")))
  245.          (and directory
  246.           (pathname-as-directory
  247.            (pathname-new-name
  248.             (pathname-as-directory (merge-pathnames directory))
  249.             user-name)))))
  250.       (merge-pathnames "\\")))
  251.  
  252. (define (file-time->local-decoded-time time)
  253.   (universal-time->local-decoded-time (file-time->universal-time time)))
  254.  
  255. (define (decoded-time->file-time dt)
  256.   (universal-time->file-time (decoded-time->universal-time dt)))
  257.  
  258. (define (file-time->universal-time time) (+ time epoch))
  259. (define (universal-time->file-time time) (- time epoch))
  260.  
  261. (define decode-file-time file-time->local-decoded-time)
  262. (define encode-file-time decoded-time->file-time)
  263. (define dos/user-home-directory user-home-directory)
  264. (define dos/current-user-name current-user-name)
  265. (define dos/current-home-directory current-home-directory)
  266.  
  267. (define (file-touch filename)
  268.   ((ucode-primitive file-touch 1)
  269.    (->namestring (merge-pathnames filename))))
  270.  
  271. (define (make-directory name)
  272.   ((ucode-primitive directory-make 1)
  273.    (->namestring (directory-pathname-as-file (merge-pathnames name)))))
  274.  
  275. (define (delete-directory name)
  276.   ((ucode-primitive directory-delete 1)
  277.    (->namestring (directory-pathname-as-file (merge-pathnames name)))))
  278.  
  279. (define (os/file-end-of-line-translation pathname)
  280.   pathname
  281.   "\r\n")
  282.  
  283. (define (os/default-end-of-line-translation)
  284.   "\r\n")
  285.  
  286. (define (initialize-system-primitives!)
  287.   (let ((reset!
  288.      (lambda ()
  289.        (reset-environment-variables!)
  290.        (cache-console-channel-descriptor!))))
  291.     (reset!)
  292.     (add-event-receiver! event:after-restart reset!)))
  293.  
  294. (define (dos/fs-drive-type pathname)
  295.   pathname
  296.   (cons "FAT" ""))
  297.  
  298. (define (dos/fs-long-filenames? pathname)
  299.   pathname
  300.   #f)
  301.  
  302. (define (copy-file from to)
  303.   (let ((input-filename (->namestring (merge-pathnames from)))
  304.     (output-filename (->namestring (merge-pathnames to))))
  305.     (let ((input-channel false)
  306.       (output-channel false))
  307.       (dynamic-wind
  308.        (lambda ()
  309.      (set! input-channel (file-open-input-channel input-filename))
  310.      (set! output-channel
  311.            (begin
  312.          ((ucode-primitive file-remove-link 1) output-filename)
  313.          (file-open-output-channel output-filename)))
  314.      unspecific)
  315.        (lambda ()
  316.      (let ((source-length (channel-file-length input-channel))
  317.            (buffer-length 8192))
  318.        (if (zero? source-length)
  319.            0
  320.            (let* ((buffer (make-string buffer-length))
  321.               (transfer
  322.                (lambda (length)
  323.              (let ((n-read
  324.                 (channel-read-block input-channel
  325.                             buffer
  326.                             0
  327.                             length)))
  328.                (if (positive? n-read)
  329.                    (channel-write-block output-channel
  330.                             buffer
  331.                             0
  332.                             n-read))
  333.                n-read))))
  334.          (let loop ((source-length source-length))
  335.            (if (< source-length buffer-length)
  336.                (transfer source-length)
  337.                (let ((n-read (transfer buffer-length)))
  338.              (if (= n-read buffer-length)
  339.                  (+ (loop (- source-length buffer-length))
  340.                 buffer-length)
  341.                  n-read))))))))
  342.        (lambda ()
  343.      (if output-channel (channel-close output-channel))
  344.      (if input-channel (channel-close input-channel)))))
  345.     (set-file-times! output-filename
  346.              #f
  347.              (file-modification-time input-filename))
  348.     (set-file-modes! output-filename (file-modes input-filename))))
  349.  
  350. (define (init-file-specifier->pathname specifier)
  351.  
  352.   (define (read-fat-init-file-map port)
  353.     (let loop ((result '()))
  354.       (let ((item (read port)))
  355.     (if (eof-object? item)
  356.         result
  357.         (begin
  358.           (if (not (and (pair? item)
  359.                 (init-file-specifier? (car item))
  360.                 (string? (cdr item))))
  361.           (error "Malformed init-file map item:" item))
  362.           (loop (cons item result)))))))
  363.  
  364.   (define (generate-fat-init-file directory)
  365.     (let loop ((index 1))
  366.       (let ((filename
  367.          (string-append "ini"
  368.                 (string-pad-left (number->string index) 5 #\0)
  369.                 ".dat")))
  370.     (if (file-exists? (merge-pathnames filename directory))
  371.         (loop (+ index 1))
  372.         filename))))
  373.  
  374.   (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME)
  375.   (let ((short-base (merge-pathnames "mitschem.ini/" (user-homedir-pathname))))
  376.     (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base)))
  377.       (let ((port #f))
  378.     (dynamic-wind
  379.      (lambda ()
  380.        (set! port (open-i/o-file file-map-pathname))
  381.        unspecific)
  382.      (lambda ()
  383.        (merge-pathnames
  384.         (or (let ((entry
  385.                (assoc specifier (read-fat-init-file-map port))))
  386.           (and entry
  387.                (cdr entry)))
  388.         (let ((filename (generate-fat-init-file short-base)))
  389.           (let ((channel (port/output-channel port)))
  390.             (channel-file-set-position
  391.              channel
  392.              (channel-file-length channel)))
  393.           (write (cons specifier filename) port)
  394.           (newline port)
  395.           filename))
  396.         short-base))
  397.      (lambda ()
  398.        (if port
  399.            (begin
  400.          (close-port port)
  401.          (set! port #f)
  402.          unspecific))))))))
  403.  
  404. (define (select-internal console? handles block?)
  405.   (let* ((nt/qs-allinput #xff)
  406.      (select
  407.       (if console?
  408.           (lambda (period)
  409.         ((ucode-primitive nt:msgwaitformultipleobjects 4)
  410.          handles #f period nt/qs-allinput))
  411.           (lambda (period)
  412.         ((ucode-primitive nt:waitformultipleobjects 3)
  413.          handles #f period)))))
  414.     (if (not block?)
  415.     (select 0)
  416.     (let loop ()
  417.       (let ((res (select 20)))
  418.         (if (zero? res)
  419.         (loop)
  420.         res))))))
  421.            
  422. (define console-channel-descriptor)
  423.  
  424. (define (cache-console-channel-descriptor!)
  425.   (set! console-channel-descriptor -1)
  426.   unspecific)
  427.  
  428. (define (select-descriptor descriptor block?)
  429.   (define (select-result result)
  430.     (cond ((fix:> result 0)
  431.        'INPUT-AVAILABLE)
  432.       ((fix:< result 0)
  433.        (error "Illegal result from select-internal" result))
  434.       (else
  435.        #f)))
  436.  
  437.   (select-result
  438.    (if (= descriptor console-channel-descriptor)
  439.        (select-internal true '#() block?)
  440.        (select-internal false (vector descriptor) block?))))
  441.  
  442. (define-structure (nt-select-registry
  443.            (conc-name nt-select-registry/)
  444.            (constructor nt-select-registry/make))
  445.   console
  446.   descriptors)
  447.  
  448. (define-integrable (find-descriptor df dl)
  449.   (list-search-positive dl
  450.     (lambda (d)
  451.       (= d df))))
  452.  
  453. (define (make-select-registry . descriptors)
  454.   (cond ((find-descriptor console-channel-descriptor descriptors)
  455.      => (lambda (ccd)
  456.           (nt-select-registry/make console-channel-descriptor
  457.                        (delq! ccd descriptors))))
  458.     (else
  459.      (nt-select-registry/make false descriptors))))
  460.  
  461. (define (add-to-select-registry! registry descriptor)
  462.   (cond ((= descriptor console-channel-descriptor)
  463.      (set-nt-select-registry/console! registry console-channel-descriptor))
  464.     ((not (find-descriptor descriptor
  465.                    (nt-select-registry/descriptors registry)))
  466.      (set-nt-select-registry/descriptors!
  467.       registry
  468.       (cons descriptor (nt-select-registry/descriptors registry))))))
  469.  
  470. (define (remove-from-select-registry! registry descriptor)
  471.   (cond ((= descriptor console-channel-descriptor)
  472.      (set-nt-select-registry/console! registry false))
  473.     ((find-descriptor descriptor (nt-select-registry/descriptors registry))
  474.      => (lambda (dr)
  475.           (set-nt-select-registry/descriptors!
  476.            registry
  477.            (delq! dr (nt-select-registry/descriptors registry)))))))
  478.  
  479. (define (select-registry-test registry block?)
  480.   (let* ((handles (list->vector (nt-select-registry/descriptors registry)))
  481.      (result (select-internal (nt-select-registry/console registry)
  482.                   handles
  483.                   block?)))
  484.     (cond ((fix:< result 0)
  485.        (error "Illegal result from select-internal" result))
  486.       ((fix:= result 0)
  487.        #f)
  488.       ((fix:> result (vector-length handles))
  489.        (list (nt-select-registry/console registry)))
  490.       (else
  491.        (list (vector-ref handles (fix:- result 1)))))))