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 / dospth.scm < prev    next >
Text File  |  2001-05-12  |  13KB  |  411 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: dospth.scm,v 1.41 2001/05/12 19:40:05 cph Exp $
  4.  
  5. Copyright (c) 1992-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. ;;;; Dos Pathnames (originally based on unxpth version 14.9)
  24. ;;; package: (runtime pathname dos)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define hook/dos/end-of-line-string)
  29.  
  30. (define sub-directory-delimiters
  31.   ;; Allow forward slashes as well as backward slashes so that
  32.   ;; - improperly-written scripts (e.g. compiler/comp.sf) will work
  33.   ;; - laziness when typing file names since the backward slash
  34.   ;;   must be quoted by another.
  35.   (char-set #\\ #\/))
  36.  
  37. (define sub-directory-delimiter-string 
  38.   "\\")
  39.  
  40. (define init-file-name "scheme.ini")
  41.  
  42. (define (make-dos-host-type index)
  43.   (make-host-type index
  44.           'DOS
  45.           dos/parse-namestring
  46.           dos/pathname->namestring
  47.           dos/make-pathname
  48.           dos/pathname-wild?
  49.           dos/directory-pathname?
  50.           dos/directory-pathname
  51.           dos/file-pathname
  52.           dos/pathname-as-directory
  53.           dos/directory-pathname-as-file
  54.           dos/pathname->truename
  55.           dos/user-homedir-pathname
  56.           dos/init-file-pathname
  57.           dos/pathname-simplify
  58.           dos/end-of-line-string))
  59.  
  60. (define (initialize-package!)
  61.   (set! hook/dos/end-of-line-string default/dos/end-of-line-string)
  62.   (add-pathname-host-type! 'DOS make-dos-host-type))
  63.  
  64. ;;;; Pathname Parser
  65.  
  66. (define (dos/parse-namestring string host)
  67.   (call-with-values
  68.       (lambda ()
  69.     (let ((components
  70.            (expand-directory-prefixes
  71.         (string-components string sub-directory-delimiters))))
  72.       (for-each string-downcase! components)
  73.       (parse-device-and-path components)))
  74.     (lambda (device components)
  75.       (call-with-values (lambda () (parse-name (car (last-pair components))))
  76.     (lambda (name type)
  77.       (dos/make-pathname
  78.        host
  79.        device
  80.        (let ((components (except-last-pair components)))
  81.          (and (not (null? components))
  82.           (simplify-directory
  83.            (if (string-null? (car components))
  84.                (cons 'ABSOLUTE
  85.                  (if (and (pair? (cdr components))
  86.                       (string-null? (cadr components)))
  87.                  ;; Handle "\\foo\bar" notation here:
  88.                  ;; the "\\foo" isn't part of the
  89.                  ;; directory path.
  90.                  (cons (cadr components)
  91.                        (parse-directory-components
  92.                     (cddr components)))
  93.                  (parse-directory-components
  94.                   (cdr components))))
  95.                (cons 'RELATIVE
  96.                  (parse-directory-components components))))))
  97.        name
  98.        type
  99.        'UNSPECIFIC))))))
  100.  
  101. (define (expand-directory-prefixes components)
  102.   (let ((string (car components))
  103.     (replace-head
  104.      (lambda (string)
  105.        ;; If STRING has a trailing slash, and it's followed by a
  106.        ;; slash, drop the trailing slash to avoid doubling.
  107.        (let ((head (string-components string sub-directory-delimiters)))
  108.          (append (if (and (pair? (cdr components))
  109.                   (pair? (cdr head))
  110.                   (string-null? (car (last-pair head))))
  111.              (except-last-pair head)
  112.              head)
  113.              (cdr components))))))
  114.     (let ((end (string-length string)))
  115.       (if (or (= 0 end)
  116.           (not *expand-directory-prefixes?*))
  117.       components
  118.       (case (string-ref string 0)
  119.         ((#\$)
  120.          (if (= 1 end)
  121.          components
  122.          (let ((value
  123.             (get-environment-variable (substring string 1 end))))
  124.            (if (not value)
  125.                components
  126.                (replace-head value)))))
  127.         ((#\~)
  128.          (let ((expansion
  129.             (ignore-errors
  130.              (lambda ()
  131.                (if (= 1 end)
  132.                (current-home-directory)
  133.                (user-home-directory (substring string 1 end)))))))
  134.            (if (condition? expansion)
  135.            components
  136.            (replace-head (->namestring expansion)))))
  137.         (else components))))))
  138.  
  139. (define (parse-device-and-path components)
  140.   (let ((string (car components)))
  141.     (if (and (fix:= (string-length string) 2)
  142.          (char=? #\: (string-ref string 1))
  143.          (char-alphabetic? (string-ref string 0)))
  144.     (values (string-head string 1) (cons "" (cdr components)))
  145.     (values #f components))))
  146.  
  147. (define (simplify-directory directory)
  148.   (cond ((and (eq? (car directory) 'RELATIVE) (null? (cdr directory))) #f)
  149.     ((equal? '(ABSOLUTE UP) directory) '(ABSOLUTE))
  150.     (else directory)))
  151.  
  152. (define (parse-directory-components components)
  153.   (if (there-exists? components string-null?)
  154.       (error "Directory contains null component:" components))
  155.   (map parse-directory-component components))
  156.  
  157. (define (parse-directory-component component)
  158.   (if (string=? ".." component)
  159.       'UP
  160.       component))
  161.  
  162. (define (string-components string delimiters)
  163.   (substring-components string 0 (string-length string) delimiters))
  164.  
  165. (define (substring-components string start end delimiters)
  166.   (let loop ((start start))
  167.     (let ((index
  168.        (substring-find-next-char-in-set string start end delimiters)))
  169.       (if index
  170.       (cons (substring string start index) (loop (fix:+ index 1)))
  171.       (list (substring string start end))))))
  172.  
  173. (define (parse-name string)
  174.   (let ((dot (string-find-previous-char string #\.))
  175.     (end (string-length string)))
  176.     (if (or (not dot)
  177.         (fix:= dot 0)
  178.         (fix:= dot (fix:- end 1))
  179.         (char=? #\. (string-ref string (fix:- dot 1))))
  180.     (values (cond ((fix:= end 0) #f)
  181.               ((string=? "*" string) 'WILD)
  182.               (else string))
  183.         #f)
  184.     (values (extract string 0 dot)
  185.         (extract string (fix:+ dot 1) end)))))
  186.  
  187. (define (extract string start end)
  188.   (if (substring=? string start end "*" 0 1)
  189.       'WILD
  190.       (substring string start end)))
  191.  
  192. ;;;; Pathname Unparser
  193.  
  194. (define (dos/pathname->namestring pathname)
  195.   (string-append (unparse-device (%pathname-device pathname))
  196.          (unparse-directory (%pathname-directory pathname))
  197.          (unparse-name (%pathname-name pathname)
  198.                    (%pathname-type pathname))))
  199.  
  200. (define (unparse-device device)
  201.   (if (or (not device) (eq? device 'UNSPECIFIC))
  202.       ""
  203.       (string-append device ":")))
  204.  
  205. (define (unparse-directory directory)
  206.   (cond ((or (not directory) (eq? directory 'UNSPECIFIC))
  207.      "")
  208.     ((pair? directory)
  209.      (string-append
  210.       (if (eq? (car directory) 'ABSOLUTE) 
  211.               sub-directory-delimiter-string
  212.               "")
  213.       (let loop ((directory (cdr directory)))
  214.         (if (null? directory)
  215.         ""
  216.         (string-append (unparse-directory-component (car directory))
  217.                    sub-directory-delimiter-string
  218.                    (loop (cdr directory)))))))
  219.     (else
  220.      (error:illegal-pathname-component directory "directory"))))
  221.  
  222. (define (unparse-directory-component component)
  223.   (cond ((eq? component 'UP) "..")
  224.     ((string? component) component)
  225.     (else
  226.      (error:illegal-pathname-component component "directory component"))))
  227.  
  228. (define (unparse-name name type)
  229.   (let ((name (or (unparse-component name) ""))
  230.     (type (unparse-component type)))
  231.     (if type
  232.     (string-append name "." type)
  233.     name)))
  234.  
  235. (define (unparse-component component)
  236.   (cond ((or (not component) (string? component)) component)
  237.     ((eq? component 'WILD) "*")
  238.     (else (error:illegal-pathname-component component "component"))))
  239.  
  240. ;;;; Pathname Constructors
  241.  
  242. (define (dos/make-pathname host device directory name type version)
  243.   (%%make-pathname
  244.    host
  245.    (cond ((string? device) device)
  246.      ((memq device '(#F UNSPECIFIC)) device)
  247.      (else (error:illegal-pathname-component device "device")))
  248.    (cond ((or (not directory) (eq? directory 'UNSPECIFIC))
  249.       directory)
  250.      ((and (list? directory)
  251.            (not (null? directory))
  252.            (memq (car directory) '(RELATIVE ABSOLUTE))
  253.            (for-all? (if (server-directory? directory)
  254.                  (cddr directory)
  255.                  (cdr directory))
  256.          (lambda (element)
  257.            (if (string? element)
  258.                (not (string-null? element))
  259.                (eq? element 'UP)))))
  260.       (simplify-directory directory))
  261.      (else
  262.       (error:illegal-pathname-component directory "directory")))
  263.    (if (or (memq name '(#F WILD))
  264.        (and (string? name) (not (string-null? name))))
  265.        name
  266.        (error:illegal-pathname-component name "name"))
  267.    (if (or (memq type '(#F WILD))
  268.        (and (string? type) (not (string-null? type))))
  269.        type
  270.        (error:illegal-pathname-component type "type"))
  271.    (if (memq version '(#F UNSPECIFIC WILD NEWEST))
  272.        'UNSPECIFIC
  273.        (error:illegal-pathname-component version "version"))))
  274.  
  275. (define (%%make-pathname host device directory name type version)
  276.   ;; This is a kludge to make the \\foo\bar notation work correctly.
  277.   ;; This kludge does not distinguish the \\foo component from any
  278.   ;; other directory component, as some rare programs might wish,
  279.   ;; because doing so is a more pervasive change.  Until someone has
  280.   ;; the energy to fix it correctly, this will have to do.
  281.   (%make-pathname host
  282.           (if (server-directory? directory) 'UNSPECIFIC device)
  283.           directory
  284.           name
  285.           type
  286.           version))
  287.  
  288. (define (server-directory? directory)
  289.   (and (pair? directory)
  290.        (eq? (car directory) 'ABSOLUTE)
  291.        (pair? (cdr directory))
  292.        (string? (cadr directory))
  293.        (string-null? (cadr directory))))
  294.  
  295. (define (dos/directory-pathname? pathname)
  296.   (and (not (%pathname-name pathname))
  297.        (not (%pathname-type pathname))))
  298.  
  299. (define (dos/directory-pathname pathname)
  300.   (%%make-pathname (%pathname-host pathname)
  301.            (%pathname-device pathname)
  302.            (%pathname-directory pathname)
  303.            #f
  304.            #f
  305.            'UNSPECIFIC))
  306.  
  307. (define (dos/file-pathname pathname)
  308.   (%%make-pathname (%pathname-host pathname)
  309.            #f
  310.            #f
  311.            (%pathname-name pathname)
  312.            (%pathname-type pathname)
  313.            (%pathname-version pathname)))
  314.  
  315. (define (dos/pathname-as-directory pathname)
  316.   (let ((name (%pathname-name pathname))
  317.     (type (%pathname-type pathname)))
  318.     (if (or name type)
  319.     (%%make-pathname
  320.      (%pathname-host pathname)
  321.      (%pathname-device pathname)
  322.      (simplify-directory
  323.       (let ((directory (%pathname-directory pathname))
  324.         (component
  325.          (parse-directory-component (unparse-name name type))))
  326.         (cond ((not (pair? directory)) (list 'RELATIVE component))
  327.           ((equal? component ".") directory)
  328.           (else (append directory (list component))))))
  329.      #f
  330.      #f
  331.      'UNSPECIFIC)
  332.     pathname)))
  333.  
  334. (define (dos/directory-pathname-as-file pathname)
  335.   (let ((directory (%pathname-directory pathname)))
  336.     (if (not (and (pair? directory)
  337.           (or (eq? 'ABSOLUTE (car directory))
  338.               (pair? (cdr directory)))))
  339.     (error:bad-range-argument pathname 'DIRECTORY-PATHNAME-AS-FILE))
  340.     (if (or (%pathname-name pathname)
  341.         (%pathname-type pathname)
  342.         (null? (cdr directory)))
  343.     pathname
  344.     (call-with-values
  345.         (lambda ()
  346.           (parse-name
  347.            (unparse-directory-component (car (last-pair directory)))))
  348.       (lambda (name type)
  349.         (%%make-pathname (%pathname-host pathname)
  350.                  (%pathname-device pathname)
  351.                  (simplify-directory (except-last-pair directory))
  352.                  name
  353.                  type
  354.                  'UNSPECIFIC))))))
  355.  
  356. ;;;; Miscellaneous
  357.  
  358. (define (dos/pathname-wild? pathname)
  359.   (let ((namestring (file-namestring pathname)))
  360.     (or (string-find-next-char namestring #\*)
  361.     (string-find-next-char namestring #\?))))
  362.  
  363. (define (dos/pathname->truename pathname)
  364.   (if (file-exists-direct? pathname)
  365.       pathname
  366.       (dos/pathname->truename
  367.        (error:file-operation pathname "find" "file" "file does not exist"
  368.                  dos/pathname->truename (list pathname)))))
  369.  
  370. (define (dos/user-homedir-pathname host)
  371.   (and (eq? host local-host)
  372.        (pathname-as-directory (current-home-directory))))
  373.  
  374. (define (dos/init-file-pathname host)
  375.   (let ((pathname
  376.      (merge-pathnames init-file-name (dos/user-homedir-pathname host))))
  377.     (and (file-exists? pathname)
  378.      pathname)))
  379.  
  380. (define (dos/pathname-simplify pathname)
  381.   (let ((directory (pathname-directory pathname)))
  382.     (or (and (pair? directory)
  383.          (let ((directory*
  384.             (cons (car directory)
  385.               (reverse!
  386.                (let loop ((elements (reverse (cdr directory))))
  387.                  (if (null? elements)
  388.                  '()
  389.                  (let ((head (car elements))
  390.                        (tail (loop (cdr elements))))
  391.                    (if (and (eq? head 'UP)
  392.                         (not (null? tail))
  393.                         (not (eq? (car tail) 'UP)))
  394.                        (cdr tail)
  395.                        (cons head tail)))))))))
  396.            (and (not (equal? directory directory*))
  397.             (let ((pathname*
  398.                (pathname-new-directory pathname directory*)))
  399.               (if (eq? 'OS/2 microcode-id/operating-system)
  400.               pathname*
  401.               (and ((ucode-primitive file-eq? 2)
  402.                 (->namestring pathname)
  403.                 (->namestring pathname*))
  404.                    pathname*))))))
  405.     pathname)))
  406.  
  407. (define (dos/end-of-line-string pathname)
  408.   (hook/dos/end-of-line-string pathname))
  409.  
  410. (define (default/dos/end-of-line-string pathname)
  411.   (or (os/file-end-of-line-translation pathname) "\n"))