home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / editors / demacs-5.arj / DIREDDOS.EL < prev    next >
Lisp/Scheme  |  1991-11-21  |  5KB  |  142 lines
  1. ;; direddos.el - DOS support for dired.
  2. ;; Copyright (C) 1991 Manabu Higashida
  3.  
  4. ;; This file is part of Demacs (MS-DOS version of GNU Emacs and Nemacs).
  5.  
  6. ;; Demacs is distributed in the forms of patches to GNU
  7. ;; Emacs under the terms of the GNU EMACS GENERAL PUBLIC
  8. ;; LICENSE which is distributed along with GNU Emacs by the
  9. ;; Free Software Foundation.
  10.  
  11. ;; Demacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied
  13. ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  14. ;; PURPOSE.  See the GNU EMACS GENERAL PUBLIC LICENSE for
  15. ;; more details.
  16.  
  17. ;; You should have received a copy of the GNU EMACS GENERAL
  18. ;; PUBLIC LICENSE along with Demacs; see the file COPYING.
  19. ;; If not, write to the Free Software Foundation, 675 Mass
  20. ;; Ave, Cambridge, MA 02139, USA. */
  21.  
  22. (setq dired-chmod-program nil)
  23. (setq dired-chgrp-program nil)
  24. (setq dired-chown-program nil)
  25. (setq dired-ls-program nil)
  26. (setq dired-compress-program nil)
  27. (setq dired-uncompress-program nil)
  28.  
  29. (defun sort-files-by-modified-time (files)
  30.   (sort files
  31.     '(lambda (a b)
  32.        (let ((aa (car (nth 5 a)))
  33.          (ab (car (cdr (nth 5 a))))
  34.          (ba (car (nth 5 b)))
  35.          (bb (car (cdr (nth 5 b)))))
  36.          (cond ((> aa ba) t)
  37.            ((= aa ba) (> ab bb))
  38.            (t nil))))))
  39.  
  40. (defun time-string-to-time-list (date)
  41.   (let* ((garbage (string-match
  42.            " \\([A-Z][a-z][a-z]\\) *\\([0-9]*\\) \\([0-9:]*\\) \\([0-9]*\\)$"
  43.            date))
  44.      (time (substring date (match-beginning 3) (match-end 3)))
  45.      (day (string-to-int
  46.            (substring date (match-beginning 2) (match-end 2))))
  47.      (month
  48.       (cdr (assoc
  49.         (substring date (match-beginning 1) (match-end 1))
  50.         '(("Jan" . 1) ("Feb" . 2)  ("Mar" . 3)  ("Apr" . 4)
  51.           ("May" . 5) ("Jun" . 6)  ("Jul" . 7)  ("Aug" . 8)
  52.           ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))))
  53.      (year (string-to-int
  54.         (substring date (match-beginning 4) (match-end 4)))))
  55.     (list year month day time)))
  56.  
  57. (defun file-modified-time-string (tem)
  58.   (let* ((mtime        (time-string-to-time-list (time-to-string tem)))
  59.      (current-time (time-string-to-time-list (current-time-string)))
  60.      (month
  61.       (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun"
  62.          "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"]
  63.         (1- (nth 1 mtime)))))
  64.     (if (and (< (nth 0 mtime) (nth 0 current-time))
  65.          (< (nth 1 mtime) (nth 1 current-time))
  66.          (< (nth 2 mtime) (nth 2 current-time))
  67.          (string< (nth 3 mtime) (nth 3 current-time)))
  68.     (format "%s %02d %5d" month (nth 2 mtime) (nth 0 mtime))
  69.       (format "%s %02d %s" month (nth 2 mtime) (substring (nth 3 mtime) 0 5)))))
  70.  
  71. (defun wildcard-to-regexp (path)
  72.   (concat "^"
  73.       (replace-letter (replace-letter path "." "\\.") "*" ".*")
  74.       "$"))
  75.  
  76. (defun list-directory-file-attributes (path &optional wildcard)
  77.   (and wildcard
  78.        (setq wildcard (wildcard-to-regexp (file-name-nondirectory path))))
  79.   (let* ((dirname (if wildcard
  80.               (file-name-directory path)
  81.             (file-name-as-directory path)))
  82.      (files (reverse (directory-files dirname)))
  83.      file place)
  84.     (while files
  85.       (setq file (car files))
  86.       (if (or (not wildcard)
  87.           (string-match wildcard file))
  88.       (setq place (cons (cons file
  89.                   (file-attributes (concat dirname file)))
  90.                 place)))
  91.       (setq files (cdr files)))
  92.     place))
  93.  
  94. (defun file-attributes-to-string (attributes)
  95.   (format "%s %3d %-8s %8d %s %s"
  96.       (nth 8 attributes)
  97.       (nth 1 attributes)
  98.       (user-login-name)
  99.       (nth 7 attributes)
  100.       (file-modified-time-string (nth 4 attributes))))
  101.  
  102. (defun dos-dired-ls (file &optional switches wildcard full-directory-p)
  103.   (or switches (setq switches dired-listing-switches))
  104.   (if (or (and full-directory-p
  105.            (not (string-match "-.*d.*" switches)))
  106.       wildcard)
  107.       (let* ((place (list-directory-file-attributes file wildcard))
  108.          filename attributes)
  109.     (if (string-match "-.*t.*" switches)
  110.         (setq place (sort-files-by-modified-time place)))
  111.     (if (string-match "-.*r.*" switches)
  112.         (setq place (reverse place)))
  113.     (insert (format "total %d file(s)\n" (length place)))
  114.     (while place
  115.       (setq filename   (car (car place))
  116.         attributes (cdr (car place)))
  117.       (insert (concat (file-attributes-to-string attributes)
  118.               " "
  119.               filename)
  120.           ?\n)
  121.       (setq place (cdr place))))
  122.     (let ((attributes (file-attributes file)))
  123.       (insert (concat (file-attributes-to-string attributes) " "
  124.               (file-name-nondirectory file))
  125.           ?\n))))
  126.  
  127.  
  128. ;;; from c-fill.el
  129. ;;;
  130. ;;; replace-letter - Given a string, an old letter and a new letter,
  131. ;;;              perform the substitution.
  132. ;;; 
  133. (defun replace-letter (str old-letter new-letter)
  134.   (let (new-str c
  135.     (sp 0)
  136.     (size (length str)))
  137.     (while (< sp size)
  138.       (setq c (substring str sp (1+ sp)))
  139.       (setq new-str (concat new-str (if (string= c old-letter) new-letter c)))
  140.       (setq sp (1+ sp)))
  141.     new-str))
  142.