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 file-name-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 (defun filename-special-filter (string)
  95   (let ((len (length string))
  96         (b 0)(i 0)
  97         (dest ""))
  98     (while (< i len)
  99       (let ((chr (sref string i))
 100             (lst filename-replacement-alist)
 101             ret)
 102         (while (and lst (not ret))
 103           (if (if (functionp (car (car lst)))
 104                   (setq ret (funcall (car (car lst)) chr))
 105                 (setq ret (memq chr (car (car lst)))))
 106               t                         ; quit this loop.
 107             (setq lst (cdr lst))))
 108         (if ret
 109             (setq dest (concat dest (substring string b i)(cdr (car lst)))
 110                   i (+ i (char-length chr))
 111                   b i)
 112           (setq i (+ i (char-length chr))))))
 113     (concat dest (substring string b))))
 114
 115 (defun filename-eliminate-top-low-lines (string)
 116   (if (string-match "^_+" string)
 117       (substring string (match-end 0))
 118     string))
 119
 120 (defun filename-canonicalize-low-lines (string)
 121   (let ((dest ""))
 122     (while (string-match "__+" string)
 123       (setq dest (concat dest (substring string 0 (1+ (match-beginning 0)))))
 124       (setq string (substring string (match-end 0))))
 125     (concat dest string)))
 126
 127 (defun filename-maybe-truncate-by-size (string)
 128   (if (and (> (length string) filename-limit-length)
 129            (string-match "_" string filename-limit-length))
 130       (substring string 0 (match-beginning 0))
 131     string))
 132
 133 (defun filename-eliminate-bottom-low-lines (string)
 134   (if (string-match "_+$" string)
 135       (substring string 0 (match-beginning 0))
 136     string))
 137
 138
 139 ;;; @ interface
 140 ;;;
 141
 142 (defun replace-as-filename (string)
 143   "Return safety filename from STRING.
 144 It refers variable `filename-filters' and default filters refers
 145 `filename-limit-length', `filename-replacement-alist'."
 146   (and string
 147        (poly-funcall filename-filters string)))
 148
 149
 150 ;;; @ end
 151 ;;;
 152
 153 (require 'product)
 154 (product-provide (provide 'filename) (require 'apel-ver))
 155
 156 ;;; filename.el ends here