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 / unxpth.scm < prev    next >
Text File  |  2001-05-12  |  11KB  |  345 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: unxpth.scm,v 14.26 2001/05/12 19:40:22 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. ;;;; Unix Pathnames
  24. ;;; package: (runtime pathname unix)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (make-unix-host-type index)
  29.   (make-host-type index
  30.           'UNIX
  31.           unix/parse-namestring
  32.           unix/pathname->namestring
  33.           unix/make-pathname
  34.           unix/pathname-wild?
  35.           unix/directory-pathname?
  36.           unix/directory-pathname
  37.           unix/file-pathname
  38.           unix/pathname-as-directory
  39.           unix/directory-pathname-as-file
  40.           unix/pathname->truename
  41.           unix/user-homedir-pathname
  42.           unix/init-file-pathname
  43.           unix/pathname-simplify
  44.           unix/end-of-line-string))
  45.  
  46. (define (initialize-package!)
  47.   (add-pathname-host-type! 'UNIX make-unix-host-type))
  48.  
  49. ;;;; Pathname Parser
  50.  
  51. (define (unix/parse-namestring string host)
  52.   (let ((end (string-length string)))
  53.     (let ((components
  54.        (expand-directory-prefixes
  55.         (substring-components string 0 end #\/))))
  56.       (parse-name (car (last-pair components))
  57.     (lambda (name type)
  58.       (%make-pathname host
  59.               'UNSPECIFIC
  60.               (let ((components (except-last-pair components)))
  61.                 (and (not (null? components))
  62.                  (simplify-directory
  63.                   (if (string=? "" (car components))
  64.                       (cons 'ABSOLUTE
  65.                         (parse-directory-components
  66.                          (cdr components)))
  67.                       (cons 'RELATIVE
  68.                         (parse-directory-components
  69.                          components))))))
  70.               name
  71.               type
  72.               'UNSPECIFIC))))))
  73.  
  74. (define (expand-directory-prefixes components)
  75.   (let ((string (car components))
  76.     (replace-head
  77.      (lambda (string)
  78.        ;; If STRING has a trailing slash, and it's followed by a
  79.        ;; slash, drop the trailing slash to avoid doubling.
  80.        (let ((head (string-components string #\/)))
  81.          (append (if (and (pair? (cdr components))
  82.                   (pair? (cdr head))
  83.                   (string-null? (car (last-pair head))))
  84.              (except-last-pair head)
  85.              head)
  86.              (cdr components))))))
  87.     (let ((end (string-length string)))
  88.       (if (or (= 0 end)
  89.           (not *expand-directory-prefixes?*))
  90.       components
  91.       (case (string-ref string 0)
  92.         ((#\$)
  93.          (if (= 1 end)
  94.          components
  95.          (let ((value
  96.             (get-environment-variable (substring string 1 end))))
  97.            (if (not value)
  98.                components
  99.                (replace-head value)))))
  100.         ((#\~)
  101.          (let ((expansion
  102.             (ignore-errors
  103.              (lambda ()
  104.                (if (= 1 end)
  105.                (current-home-directory)
  106.                (user-home-directory (substring string 1 end)))))))
  107.            (if (condition? expansion)
  108.            components
  109.            (replace-head (->namestring expansion)))))
  110.         (else components))))))
  111.  
  112. (define (simplify-directory directory)
  113.   (if (and (eq? (car directory) 'RELATIVE) (null? (cdr directory)))
  114.       #f
  115.       directory))
  116.  
  117. (define (parse-directory-components components)
  118.   (if (there-exists? components string-null?)
  119.       (error "Directory contains null component:" components))
  120.   (map parse-directory-component components))
  121.  
  122. (define (parse-directory-component component)
  123.   (if (string=? ".." component)
  124.       'UP
  125.       component))
  126.  
  127. (define (string-components string delimiter)
  128.   (substring-components string 0 (string-length string) delimiter))
  129.  
  130. (define (substring-components string start end delimiter)
  131.   (let loop ((start start))
  132.     (let ((index (substring-find-next-char string start end delimiter)))
  133.       (if index
  134.       (cons (substring string start index) (loop (+ index 1)))
  135.       (list (substring string start end))))))
  136.  
  137. (define (parse-name string receiver)
  138.   (let ((end (string-length string)))
  139.     (let ((dot (substring-find-previous-char string 0 end #\.)))
  140.       (if (or (not dot)
  141.           (= dot 0)
  142.           (= dot (- end 1))
  143.           (char=? #\. (string-ref string (- dot 1))))
  144.       (receiver (cond ((= end 0) #f)
  145.               ((string=? "*" string) 'WILD)
  146.               (else string))
  147.             #f)
  148.       (receiver (extract string 0 dot)
  149.             (extract string (+ dot 1) end))))))
  150.  
  151. (define (extract string start end)
  152.   (if (substring=? string start end "*" 0 1)
  153.       'WILD
  154.       (substring string start end)))
  155.  
  156. ;;;; Pathname Unparser
  157.  
  158. (define (unix/pathname->namestring pathname)
  159.   (string-append (unparse-directory (%pathname-directory pathname))
  160.          (unparse-name (%pathname-name pathname)
  161.                    (%pathname-type pathname))))
  162.  
  163. (define (unparse-directory directory)
  164.   (cond ((not directory)
  165.      "")
  166.     ((pair? directory)
  167.      (string-append
  168.       (if (eq? (car directory) 'ABSOLUTE) "/" "")
  169.       (let loop ((directory (cdr directory)))
  170.         (if (null? directory)
  171.         ""
  172.         (string-append (unparse-directory-component (car directory))
  173.                    "/"
  174.                    (loop (cdr directory)))))))
  175.     (else
  176.      (error:illegal-pathname-component directory "directory"))))
  177.  
  178. (define (unparse-directory-component component)
  179.   (cond ((eq? component 'UP) "..")
  180.     ((string? component) component)
  181.     (else
  182.      (error:illegal-pathname-component component "directory component"))))
  183.  
  184. (define (unparse-name name type)
  185.   (let ((name (or (unparse-component name) ""))
  186.     (type (unparse-component type)))
  187.     (if type
  188.     (string-append name "." type)
  189.     name)))
  190.  
  191. (define (unparse-component component)
  192.   (cond ((or (not component) (string? component)) component)
  193.     ((eq? component 'WILD) "*")
  194.     (else (error:illegal-pathname-component component "component"))))
  195.  
  196. ;;;; Pathname Constructors
  197.  
  198. (define (unix/make-pathname host device directory name type version)
  199.   (%make-pathname
  200.    host
  201.    (if (memq device '(#F UNSPECIFIC))
  202.        'UNSPECIFIC
  203.        (error:illegal-pathname-component device "device"))
  204.    (cond ((not directory)
  205.       directory)
  206.      ((and (list? directory)
  207.            (not (null? directory))
  208.            (memq (car directory) '(RELATIVE ABSOLUTE))
  209.            (for-all? (cdr directory)
  210.          (lambda (element)
  211.            (if (string? element)
  212.                (not (string-null? element))
  213.                (eq? element 'UP)))))
  214.       (simplify-directory directory))
  215.      (else
  216.       (error:illegal-pathname-component directory "directory")))
  217.    (if (or (memq name '(#F WILD))
  218.        (and (string? name) (not (string-null? name))))
  219.        name
  220.        (error:illegal-pathname-component name "name"))
  221.    (if (or (memq type '(#F WILD))
  222.        (and (string? type) (not (string-null? type))))
  223.        type
  224.        (error:illegal-pathname-component type "type"))
  225.    (if (memq version '(#F UNSPECIFIC WILD NEWEST))
  226.        'UNSPECIFIC
  227.        (error:illegal-pathname-component version "version"))))
  228.  
  229. (define (unix/directory-pathname? pathname)
  230.   (and (not (%pathname-name pathname))
  231.        (not (%pathname-type pathname))))
  232.  
  233. (define (unix/directory-pathname pathname)
  234.   (%make-pathname (%pathname-host pathname)
  235.           (%pathname-device pathname)
  236.           (%pathname-directory pathname)
  237.           #f
  238.           #f
  239.           'UNSPECIFIC))
  240.  
  241. (define (unix/file-pathname pathname)
  242.   (%make-pathname (%pathname-host pathname)
  243.           'UNSPECIFIC
  244.           #f
  245.           (%pathname-name pathname)
  246.           (%pathname-type pathname)
  247.           (%pathname-version pathname)))
  248.  
  249. (define (unix/pathname-as-directory pathname)
  250.   (let ((name (%pathname-name pathname))
  251.     (type (%pathname-type pathname)))
  252.     (if (or name type)
  253.     (%make-pathname
  254.      (%pathname-host pathname)
  255.      'UNSPECIFIC
  256.      (let ((directory (%pathname-directory pathname))
  257.            (component
  258.         (parse-directory-component (unparse-name name type))))
  259.        (cond ((not (pair? directory))
  260.           (list 'RELATIVE component))
  261.          ((equal? component ".")
  262.           directory)
  263.          (else
  264.           (append directory (list component)))))
  265.      #f
  266.      #f
  267.      'UNSPECIFIC)
  268.     pathname)))
  269.  
  270. (define (unix/directory-pathname-as-file pathname)
  271.   (let ((directory (%pathname-directory pathname)))
  272.     (if (not (and (pair? directory)
  273.           (or (eq? 'ABSOLUTE (car directory))
  274.               (pair? (cdr directory)))))
  275.     (error:bad-range-argument pathname 'DIRECTORY-PATHNAME-AS-FILE))
  276.     (if (or (%pathname-name pathname)
  277.         (%pathname-type pathname)
  278.         (null? (cdr directory)))
  279.     ;; Root directory can't be represented as a file, because the
  280.     ;; name field of a pathname must be a non-null string.  We
  281.     ;; could signal an error here, but instead we'll just return
  282.     ;; the original pathname and leave it to the caller to deal
  283.     ;; with any problems this might cause.
  284.     pathname
  285.     (parse-name (unparse-directory-component (car (last-pair directory)))
  286.       (lambda (name type)
  287.         (%make-pathname (%pathname-host pathname)
  288.                 'UNSPECIFIC
  289.                 (simplify-directory (except-last-pair directory))
  290.                 name
  291.                 type
  292.                 'UNSPECIFIC))))))
  293.  
  294. ;;;; Miscellaneous
  295.  
  296. (define (unix/pathname-wild? pathname)
  297.   (or (eq? 'WILD (%pathname-name pathname))
  298.       (eq? 'WILD (%pathname-type pathname))))
  299.  
  300. (define (unix/pathname->truename pathname)
  301.   (if (file-exists-direct? pathname)
  302.       pathname
  303.       (unix/pathname->truename
  304.        (error:file-operation pathname "find" "file" "file does not exist"
  305.                  unix/pathname->truename (list pathname)))))
  306.  
  307. (define (unix/user-homedir-pathname host)
  308.   (and (eq? host local-host)
  309.        (pathname-as-directory (current-home-directory))))
  310.  
  311. (define (unix/init-file-pathname host)
  312.   (let ((pathname
  313.      (merge-pathnames ".scheme.init" (unix/user-homedir-pathname host))))
  314.     (and (file-exists? pathname)
  315.      pathname)))
  316.  
  317. (define (unix/pathname-simplify pathname)
  318.   (or (and (implemented-primitive-procedure? (ucode-primitive file-eq? 2))
  319.        (let ((directory (pathname-directory pathname)))
  320.          (and (pair? directory)
  321.           (let ((directory*
  322.              (cons (car directory)
  323.                    (reverse!
  324.                 (let loop
  325.                     ((elements (reverse (cdr directory))))
  326.                   (if (null? elements)
  327.                       '()
  328.                        (let ((head (car elements))
  329.                          (tail (loop (cdr elements))))
  330.                      (if (and (eq? head 'UP)
  331.                           (not (null? tail))
  332.                           (not (eq? (car tail) 'UP)))
  333.                          (cdr tail)
  334.                          (cons head tail)))))))))
  335.             (and (not (equal? directory directory*))
  336.              (let ((pathname*
  337.                 (pathname-new-directory pathname directory*)))
  338.                (and ((ucode-primitive file-eq? 2)
  339.                  (->namestring pathname)
  340.                  (->namestring pathname*))
  341.                 pathname*)))))))
  342.       pathname))
  343.  
  344. (define (unix/end-of-line-string pathname)
  345.   (or (os/file-end-of-line-translation pathname) "\n"))