Changeset 10035


Ignore:
Timestamp:
09/26/05 01:15:39 (16 years ago)
Author:
piso
Message:

Work in progress.

Location:
trunk/j/src/org/armedbear/lisp/tests
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/tests/file-system-tests.lisp

    r10034 r10035  
    4040(setf rt:*expected-failures* nil)
    4141
    42 (defpackage #:file-system-tests (:use #:cl #:regression-test
    43                                         #+abcl #:ext))
    44 
    45 (in-package #:file-system-tests)
     42(unless (find-package '#:test)
     43  (defpackage #:test (:use #:cl #:regression-test
     44                           #+abcl #:extensions)))
     45
     46(in-package #:test)
     47
     48(export '(pathnames-equal-p run-shell-command copy-file make-symbolic-link))
    4649
    4750(defparameter *this-file*
     
    120123    :input nil :output output)))
    121124
     125(defun copy-file (from to)
     126  (let* ((from-namestring (namestring (pathname from)))
     127         (to-namestring (namestring (pathname to)))
     128         (command (concatenate 'string "cp " from-namestring " " to-namestring)))
     129    (zerop (run-shell-command command))))
     130
     131(defun make-symbolic-link (from to)
     132  (let* ((from-namestring (namestring (pathname from)))
     133         (to-namestring (namestring (pathname to)))
     134         (command (concatenate 'string "ln -s " from-namestring " " to-namestring)))
     135    (zerop (run-shell-command command))))
     136
    122137;; This approach is race-prone, but it should be adequate for our limited
    123138;; purposes here.
     
    163178  t)
    164179
     180(deftest probe-file.1
     181  (pathnames-equal-p (probe-file *this-file*) *this-file*)
     182  t)
     183
     184(deftest truename.1
     185  (pathnames-equal-p (truename *this-file*) *this-file*)
     186  t)
     187
     188(deftest directory.1
     189  (let ((list (directory *this-file*)))
     190    (and
     191     (= (length list) 1)
     192     (pathnames-equal-p (car list) *this-file*)))
     193  t)
     194
    165195#-windows
    166196(deftest symlink.1
    167197  (let* ((tmp1 (make-temporary-filename *this-directory*))
    168          (command1 (concatenate 'string "cp "
    169                                 (namestring *this-file*)
    170                                 " "
    171                                 (namestring tmp1))))
     198         (tmp2 (make-temporary-filename *this-directory*)))
    172199    (unwind-protect
    173         (let* ((tmp2 (make-temporary-filename *this-directory*))
    174                (command2 (concatenate 'string "ln -sf "
    175                                       (namestring tmp1)
    176                                       " "
    177                                       (namestring tmp2))))
    178           (values
    179            (unwind-protect
    180                (and
    181                 ;; Copy this file.
    182                 (zerop (run-shell-command command1 :directory *this-directory*))
    183                 (pathnames-equal-p (probe-file tmp1) tmp1)
    184                 ;; Create a symlink to the copy.
    185                 (zerop (run-shell-command command2 :directory *this-directory*))
    186                 ;; Verify that the symlink exists and points to the copy.
    187                 (pathnames-equal-p (probe-file tmp2) tmp1)
    188                 (pathnames-equal-p (truename tmp2) tmp1))
    189              (when (probe-file tmp2)
    190                (delete-file tmp2)))
    191            ;; Copy should still exist after symlink is deleted.
    192            (pathnames-equal-p (probe-file tmp1) tmp1)))
     200        (values
     201         (unwind-protect
     202             (and
     203              ;; Copy this file to tmp1.
     204              (copy-file *this-file* tmp1)
     205              (pathnames-equal-p (probe-file tmp1) tmp1)
     206              ;; Create tmp2 as a symlink to tmp1.
     207              (make-symbolic-link tmp1 tmp2)
     208              ;; Verify that the symlink exists and points to the copy.
     209              (pathnames-equal-p (probe-file tmp2) tmp1)
     210              (pathnames-equal-p (truename tmp2) tmp1))
     211           ;; Delete the symlink.
     212           (when (probe-file tmp2)
     213             (delete-file tmp2)))
     214         ;; Copy should still exist after symlink is deleted.
     215         (pathnames-equal-p (probe-file tmp1) tmp1))
    193216      (when (probe-file tmp1)
    194217        (delete-file tmp1))))
    195218  t t)
    196219#+allegro
    197 ;; Allegro's PROBE-FILE doesn't follow the symlink, which is a bug.
     220;; Allegro's PROBE-FILE doesn't follow the symlink.
    198221(pushnew 'symlink.1 *expected-failures*)
    199222
     223#-windows
     224(deftest symlink.2
     225  (let* ((copy (make-temporary-filename *this-directory*))
     226         (link (make-temporary-filename *this-directory*))
     227         directory)
     228    (unwind-protect
     229        (and
     230         ;; Copy this file to copy.
     231         (copy-file *this-file* copy)
     232         ;; Verify that copy exists.
     233         (pathnames-equal-p (probe-file copy) copy)
     234         ;; Create link as a symlink to copy.
     235         (make-symbolic-link copy link)
     236         ;; Verify that the symlink appears in the directory listing.
     237         (setf directory (directory link))
     238         (= (length directory) 1)
     239         ;; The directory listing should contain the truename of the symlink.
     240         (pathnames-equal-p (car directory) (truename link)))
     241      (progn
     242        ;; Clean up.
     243        (when (probe-file link)
     244          (delete-file link))
     245        (when (probe-file copy)
     246          (delete-file copy)))))
     247  t)
     248#+allegro
     249(pushnew 'symlink.2 *expected-failures*)
     250
    200251(do-tests)
  • trunk/j/src/org/armedbear/lisp/tests/pathname-tests.lisp

    r10029 r10035  
    22;;;
    33;;; Copyright (C) 2005 Peter Graves
    4 ;;; $Id: pathname-tests.lisp,v 1.26 2005-09-25 18:49:38 piso Exp $
     4;;; $Id: pathname-tests.lisp,v 1.27 2005-09-26 01:15:39 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    4141(setf rt:*expected-failures* nil)
    4242
    43 (defpackage #:pathname-tests (:use #:cl #:regression-test))
    44 
    45 (in-package #:pathname-tests)
     43(unless (find-package '#:test)
     44  (defpackage #:pathname-tests (:use #:cl #:regression-test
     45                                     #+abcl #:extensions)))
     46
     47(in-package #:test)
    4648
    4749(defmacro signals-error (form error-name)
Note: See TracChangeset for help on using the changeset viewer.