Mercurial > hg > xemacs-beta

comparison lisp/apel/filename.el @ 155:43dd3413c7c7 r20-3b4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b4
author cvs
date Mon, 13 Aug 2007 09:39:39 +0200
parents
children
comparison
equal deleted inserted replaced
154:94141801dd7e 155:43dd3413c7c7
1 ;;; filename.el --- file name filter
2
3 ;; Copyright (C) 1996,1997 MORIOKA Tomohiko
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Version: $Id: filename.el,v 1.1 1997/06/03 04:18:35 steve Exp $
7 ;; Keywords: file name, string
8
9 ;; This file is part of APEL (A Portable Emacs Library).
10
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
15
16 ;; This program is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Code:
27
28 (require 'emu)
29 (require 'cl)
30
31 (defsubst poly-funcall (functions argument)
32 "Apply initial ARGUMENT to sequence of FUNCTIONS.
33 FUNCTIONS is list of functions.
34
35 (poly-funcall '(f1 f2 .. fn) arg) is as same as
36 (fn .. (f2 (f1 arg)) ..).
37
38 For example, (poly-funcall '(car number-to-string) '(100)) returns
39 \"100\"."
40 (while functions
41 (setq argument (funcall (car functions) argument)
42 functions (cdr functions))
43 )
44 argument)
45
46
47 ;;; @ variables
48 ;;;
49
50 (defvar filename-limit-length 21 "Limit size of file-name.")
51
52 (defvar filename-replacement-alist
53 '(((?\ ?\t) . "_")
54 ((?! ?\" ?# ?$ ?% ?& ?' ?\( ?\) ?* ?/
55 ?: ?\; ?< ?> ?? ?\[ ?\\ ?\] ?` ?{ ?| ?}) . "_")
56 (filename-control-p . "")
57 )
58 "Alist list of characters vs. string as replacement.
59 List of characters represents characters not allowed as file-name.")
60
61 (defvar filename-filters
62 (let ((filters '(filename-special-filter
63 filename-eliminate-top-low-lines
64 filename-canonicalize-low-lines
65 filename-maybe-truncate-by-size
66 filename-eliminate-bottom-low-lines
67 )))
68 (require 'file-detect)
69 (if (exec-installed-p "kakasi")
70 (cons 'filename-japanese-to-roman-string filters)
71 filters))
72 "List of functions for file-name filter.")
73
74
75 ;;; @ filters
76 ;;;
77
78 (defun filename-japanese-to-roman-string (str)
79 (save-excursion
80 (set-buffer (get-buffer-create " *temp kakasi*"))
81 (erase-buffer)
82 (insert str)
83 (call-process-region (point-min)(point-max) "kakasi" t t t
84 "-Ha" "-Ka" "-Ja" "-Ea" "-ka")
85 (buffer-string)
86 ))
87
88 (defun filename-control-p (character)
89 (let ((code (char-int character)))
90 (or (< code 32)(= code 127))
91 ))
92
93 (defun filename-special-filter (string)
94 (let (dest
95 (i 0)
96 (len (length string))
97 (b 0)
98 )
99 (while (< i len)
100 (let* ((chr (sref string i))
101 (ret (assoc-if (function
102 (lambda (key)
103 (if (functionp key)
104 (funcall key chr)
105 (memq chr key)
106 )))
107 filename-replacement-alist))
108 )
109 (if ret
110 (setq dest (concat dest (substring string b i)(cdr ret))
111 i (+ i (char-length chr))
112 b i)
113 (setq i (+ i (char-length chr)))
114 )))
115 (concat dest (substring string b))
116 ))
117
118 (defun filename-eliminate-top-low-lines (string)
119 (if (string-match "^_+" string)
120 (substring string (match-end 0))
121 string))
122
123 (defun filename-canonicalize-low-lines (string)
124 (let (dest)
125 (while (string-match "__+" string)
126 (setq dest (concat dest (substring string 0 (1+ (match-beginning 0)))))
127 (setq string (substring string (match-end 0)))
128 )
129 (concat dest string)
130 ))
131
132 (defun filename-maybe-truncate-by-size (string)
133 (if (and (> (length string) filename-limit-length)
134 (string-match "_" string filename-limit-length)
135 )
136 (substring string 0 (match-beginning 0))
137 string))
138
139 (defun filename-eliminate-bottom-low-lines (string)
140 (if (string-match "_+$" string)
141 (substring string 0 (match-beginning 0))
142 string))
143
144
145 ;;; @ interface
146 ;;;
147
148 (defun replace-as-filename (string)
149 "Return safety filename from STRING.
150 It refers variable `filename-filters' and default filters refers
151 `filename-limit-length', `filename-replacement-alist'."
152 (and string
153 (poly-funcall filename-filters string)
154 ))
155
156
157 ;;; @ end
158 ;;;
159
160 (provide 'filename)
161
162 ;;; filename.el ends here