filename.el

   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 2.1 1997/11/06 15:50:53 morioka 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)                          ; for backward compatibility.
  29 (require 'poe)                          ; functionp.
  30 (require 'poem)                         ; char-int, and char-length.
  31 (require 'path-util)
  32
  33 (defsubst poly-funcall (functions argument)
  34   "Apply initial ARGUMENT to sequence of FUNCTIONS.
  35 FUNCTIONS is list of functions.
  36
  37 \(poly-funcall '(f1 f2 .. fn) arg) is as same as
  38 \(fn .. (f2 (f1 arg)) ..).
  39
  40 For example, (poly-funcall '(car number-to-string) '(100)) returns
  41 \"100\"."
  42   (while functions
  43     (setq argument (funcall (car functions) argument)
  44           functions (cdr functions)))
  45   argument)
  46
  47
  48 ;;; @ variables
  49 ;;;
  50
  51 (defvar filename-limit-length 21 "Limit size of file-name.")
  52
  53 (defvar filename-replacement-alist
  54   '(((?\  ?\t) . "_")
  55     ((?! ?\" ?# ?$ ?% ?& ?' ?\( ?\) ?* ?/
  56          ?: ?\; ?< ?> ?? ?\[ ?\\ ?\] ?` ?{ ?| ?}) . "_")
  57     (filename-control-p . ""))
  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 nil
  62   "List of functions for file-name filter.
  63
  64 Example:
  65 \(setq filename-filters '\(filename-special-filter
  66                          filename-eliminate-top-low-lines
  67                          filename-canonicalize-low-lines
  68                          filename-maybe-truncate-by-size
  69                          filename-eliminate-bottom-low-lines\)\)
  70
  71 Moreover, if you want to convert Japanese filename to roman string by kakasi,
  72
  73 \(if \(exec-installed-p \"kakasi\"\)
  74     \(setq filename-filters
  75           \(append '\(filename-japanese-to-roman-string\) filename-filters\)\)\)")
  76
  77 ;;; @ filters
  78 ;;;
  79
  80 (defun filename-japanese-to-roman-string (str)
  81   (save-excursion
  82     (set-buffer (get-buffer-create " *temp kakasi*"))
  83     (erase-buffer)
  84     (insert str)
  85     (call-process-region
  86      (point-min)(point-max)
  87      "kakasi" t t t "-Ha" "-Ka" "-Ja" "-Ea" "-ka")
  88     (buffer-string)))
  89
  90 (defun filename-control-p (character)
  91   (let ((code (char-int character)))
  92     (or (< code 32)(= code 127))))
  93
  94 (eval-when-compile
  95   (defmacro filename-special-filter-1 (string)
  96     (let (sref inc-i)
  97       (if (or (not (fboundp 'sref))
  98               (>= emacs-major-version 21)
  99               (and (= emacs-major-version 20)
 100                    (>= emacs-minor-version 3)))
 101           (setq sref 'aref
 102                 inc-i '(1+ i))
 103         (setq sref 'aref
 104               inc-i '(+ i (char-length chr))))
 105       (` (let* ((string (, string))
 106                 (len (length string))
 107                 (b 0)(i 0)
 108                 (dest ""))
 109            (while (< i len)
 110              (let ((chr ((, sref) string i))
 111                    (lst filename-replacement-alist)
 112                    ret)
 113                (while (and lst (not ret))
 114                  (if (if (functionp (car (car lst)))
 115                          (setq ret (funcall (car (car lst)) chr))
 116                        (setq ret (memq chr (car (car lst)))))
 117                      t                  ; quit this loop.
 118                    (setq lst (cdr lst))))
 119                (if ret
 120                    (setq dest (concat dest (substring string b i)
 121                                       (cdr (car lst)))
 122                          i (, inc-i)
 123                          b i)
 124                  (setq i (, inc-i)))))
 125            (concat dest (substring string b)))))))
 126
 127 (defun filename-special-filter (string)
 128   (filename-special-filter-1 string))
 129
 130 (defun filename-eliminate-top-low-lines (string)
 131   (if (string-match "^_+" string)
 132       (substring string (match-end 0))
 133     string))
 134
 135 (defun filename-canonicalize-low-lines (string)
 136   (let ((dest ""))
 137     (while (string-match "__+" string)
 138       (setq dest (concat dest (substring string 0 (1+ (match-beginning 0)))))
 139       (setq string (substring string (match-end 0))))
 140     (concat dest string)))
 141
 142 (defun filename-maybe-truncate-by-size (string)
 143   (if (and (> (length string) filename-limit-length)
 144            (string-match "_" string filename-limit-length))
 145       (substring string 0 (match-beginning 0))
 146     string))
 147
 148 (defun filename-eliminate-bottom-low-lines (string)
 149   (if (string-match "_+$" string)
 150       (substring string 0 (match-beginning 0))
 151     string))
 152
 153
 154 ;;; @ interface
 155 ;;;
 156
 157 (defun replace-as-filename (string)
 158   "Return safety filename from STRING.
 159 It refers variable `filename-filters' and default filters refers
 160 `filename-limit-length', `filename-replacement-alist'."
 161   (and string
 162        (poly-funcall filename-filters string)))
 163
 164
 165 ;;; @ end
 166 ;;;
 167
 168 (require 'product)
 169 (product-provide (provide 'filename) (require 'apel-ver))
 170
 171 ;;; filename.el ends here