X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fapel.git;a=blobdiff_plain;f=filename.el;h=bbe1f9ad069b59466367b7658189a8afe0e8016d;hp=34853fba78449e0fd2660736d88b24f3dcc1c2e1;hb=8821cfcb77c5c60e039a016a9e4cd92dc7799648;hpb=150a4ca2722f12b9c6f689c9bd3da0f407090bed

diff --git a/filename.el b/filename.el
index 34853fb..bbe1f9a 100644
--- a/filename.el
+++ b/filename.el
@@ -1,12 +1,12 @@
 ;;; filename.el --- file name filter
 
-;; Copyright (C) 1996 MORIOKA Tomohiko
+;; Copyright (C) 1996,1997 MORIOKA Tomohiko
 
 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Id: filename.el,v 1.1 1996/12/16 13:42:14 morioka Exp $
-;; Keywords: string, file name
+;; Version: $Id: filename.el,v 2.1 1997/11/06 15:50:53 morioka Exp $
+;; Keywords: file name, string
 
-;; This file is part of tl (Tiny Library).
+;; This file is part of APEL (A Portable Emacs Library).
 
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU General Public License as
@@ -25,33 +25,50 @@
 
 ;;; Code:
 
-(require 'tl-list)
-(require 'tl-str)
+(require 'emu)				; for backward compatibility.
+(require 'poe)				; functionp.
+(require 'poem)				; char-int, and char-length.
+(require 'path-util)
+
+(defsubst poly-funcall (functions argument)
+  "Apply initial ARGUMENT to sequence of FUNCTIONS.
+FUNCTIONS is list of functions.
+
+(poly-funcall '(f1 f2 .. fn) arg) is as same as
+(fn .. (f2 (f1 arg)) ..).
+
+For example, (poly-funcall '(car number-to-string) '(100)) returns
+\"100\"."
+  (while functions
+    (setq argument (funcall (car functions) argument)
+	  functions (cdr functions)))
+  argument)
 
 
 ;;; @ variables
 ;;;
 
-(defvar filename-limit-length 21)
+(defvar filename-limit-length 21 "Limit size of file-name.")
 
 (defvar filename-replacement-alist
-  (list
-   (cons (string-to-char-list " \t") "_")
-   (cons (string-to-char-list (expand-char-ranges "!-*,/:;<>?[-^`{-~")) "_")
-   '(filename-control-p . "")
-   ))
+  '(((?\  ?\t) . "_")
+    ((?! ?\" ?# ?$ ?% ?& ?' ?\( ?\) ?* ?/
+	 ?: ?\; ?< ?> ?? ?\[ ?\\ ?\] ?` ?{ ?| ?}) . "_")
+    (filename-control-p . ""))
+  "Alist list of characters vs. string as replacement.
+List of characters represents characters not allowed as file-name.")
 
 (defvar filename-filters
-  (nconc
-   (and (file-installed-p "kakasi" exec-path)
-	'(filename-japanese-to-roman-string)
-	)
-   '(filename-special-filter
-     filename-eliminate-top-low-lines
-     filename-canonicalize-low-lines
-     filename-maybe-truncate-by-size
-     filename-eliminate-bottom-low-lines
-     )))
+  (let ((filters '(filename-special-filter
+		   filename-eliminate-top-low-lines
+		   filename-canonicalize-low-lines
+		   filename-maybe-truncate-by-size
+		   filename-eliminate-bottom-low-lines
+		   )))
+    (if (exec-installed-p "kakasi")
+	(cons 'filename-japanese-to-roman-string filters)
+      filters))
+  "List of functions for file-name filter.")
 
 
 ;;; @ filters
@@ -62,41 +79,35 @@
     (set-buffer (get-buffer-create " *temp kakasi*"))
     (erase-buffer)
     (insert str)
-    (call-process-region (point-min)(point-max) "kakasi" t t t
-			 "-Ha" "-Ka" "-Ja" "-Ea" "-ka")
-    (buffer-string)
-    ))
+    (call-process-region
+     (point-min)(point-max)
+     "kakasi" t t t "-Ha" "-Ka" "-Ja" "-Ea" "-ka")
+    (buffer-string)))
 
 (defun filename-control-p (character)
   (let ((code (char-int character)))
-    (or (< code 32)(= code 127))
-    ))
+    (or (< code 32)(= code 127))))
 
 (defun filename-special-filter (string)
-  (let (dest
-	(i 0)
-	(len (length string))
-	(b 0)
-	)
+  (let ((len (length string))
+	(b 0)(i 0)
+	(dest ""))
     (while (< i len)
-      (let* ((chr (sref string i))
-	     (ret (ASSOC chr filename-replacement-alist
-			 :test (function
-				(lambda (chr key)
-				  (if (functionp key)
-				      (funcall key chr)
-				    (memq chr key)
-				    )
-				  ))))
-	     )
+      (let ((chr (sref string i))
+            (lst filename-replacement-alist)
+            ret)
+        (while (and lst (not ret))
+          (if (if (functionp (car (car lst)))
+                  (setq ret (funcall (car (car lst)) chr))
+                (setq ret (memq chr (car (car lst)))))
+              t                         ; quit this loop.
+            (setq lst (cdr lst))))
 	(if ret
-	    (setq dest (concat dest (substring string b i)(cdr ret))
+	    (setq dest (concat dest (substring string b i)(cdr (car lst)))
 		  i (+ i (char-length chr))
 		  b i)
-	  (setq i (+ i (char-length chr)))
-	  )))
-    (concat dest (substring string b))
-    ))
+	  (setq i (+ i (char-length chr))))))
+    (concat dest (substring string b))))
 
 (defun filename-eliminate-top-low-lines (string)
   (if (string-match "^_+" string)
@@ -104,18 +115,15 @@
     string))
 
 (defun filename-canonicalize-low-lines (string)
-  (let (dest)
+  (let ((dest ""))
     (while (string-match "__+" string)
       (setq dest (concat dest (substring string 0 (1+ (match-beginning 0)))))
-      (setq string (substring string (match-end 0)))
-      )
-    (concat dest string)
-    ))
+      (setq string (substring string (match-end 0))))
+    (concat dest string)))
 
 (defun filename-maybe-truncate-by-size (string)
   (if (and (> (length string) filename-limit-length)
-	   (string-match "_" string filename-limit-length)
-	   )
+	   (string-match "_" string filename-limit-length))
       (substring string 0 (match-beginning 0))
     string))
 
@@ -129,14 +137,17 @@
 ;;;
 
 (defun replace-as-filename (string)
-  "Return safety filename from STRING. [filename.el]"
-  (poly-funcall filename-filters string)
-  )
+  "Return safety filename from STRING.
+It refers variable `filename-filters' and default filters refers
+`filename-limit-length', `filename-replacement-alist'."
+  (and string
+       (poly-funcall filename-filters string)))
 
 
 ;;; @ end
 ;;;
 
-(provide 'filename)
+(require 'product)
+(product-provide (provide 'filename) (require 'apel-ver))
 
 ;;; filename.el ends here