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., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, 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 ((len (length (, string)))
 106                (b 0)(i 0)
 107                (dest ""))
 108            (while (< i len)
 109              (let ((chr ((, sref) (, string) i))
 110                    (lst filename-replacement-alist)
 111                    ret)
 112                (while (and lst (not ret))
 113                  (if (if (functionp (car (car lst)))
 114                          (setq ret (funcall (car (car lst)) chr))
 115                        (setq ret (memq chr (car (car lst)))))
 116                      t                  ; quit this loop.
 117                    (setq lst (cdr lst))))
 118                (if ret
 119                    (setq dest (concat dest (substring (, string) b i)
 120                                       (cdr (car lst)))
 121                          i (, inc-i)
 122                          b i)
 123                  (setq i (, inc-i)))))
 124            (concat dest (substring (, string) b)))))))
 125
 126 (defun filename-special-filter (string)
 127   (filename-special-filter-1 string))
 128
 129 (defun filename-eliminate-top-low-lines (string)
 130   (if (string-match "^_+" string)
 131       (substring string (match-end 0))
 132     string))
 133
 134 (defun filename-canonicalize-low-lines (string)
 135   (let ((dest ""))
 136     (while (string-match "__+" string)
 137       (setq dest (concat dest (substring string 0 (1+ (match-beginning 0)))))
 138       (setq string (substring string (match-end 0))))
 139     (concat dest string)))
 140
 141 (defun filename-maybe-truncate-by-size (string)
 142   (if (and (> (length string) filename-limit-length)
 143            (string-match "_" string filename-limit-length))
 144       (substring string 0 (match-beginning 0))
 145     string))
 146
 147 (defun filename-eliminate-bottom-low-lines (string)
 148   (if (string-match "_+$" string)
 149       (substring string 0 (match-beginning 0))
 150     string))
 151
 152
 153 ;;; @ interface
 154 ;;;
 155
 156 (defun replace-as-filename (string)
 157   "Return safety filename from STRING.
 158 It refers variable `filename-filters' and default filters refers
 159 `filename-limit-length', `filename-replacement-alist'."
 160   (and string
 161        (poly-funcall filename-filters string)))
 162
 163
 164 ;;; @ end
 165 ;;;
 166
 167 (require 'product)
 168 (product-provide (provide 'filename) (require 'apel-ver))
 169
 170 ;;; filename.el ends here