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
  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     (if (exec-installed-p "kakasi")
  69         (cons 'filename-japanese-to-roman-string filters)
  70       filters))
  71   "List of functions for file-name filter.")
  72
  73
  74 ;;; @ filters
  75 ;;;
  76
  77 (defun filename-japanese-to-roman-string (str)
  78   (save-excursion
  79     (set-buffer (get-buffer-create " *temp kakasi*"))
  80     (erase-buffer)
  81     (insert str)
  82     (call-process-region
  83      (point-min)(point-max)
  84      "kakasi" t t t "-Ha" "-Ka" "-Ja" "-Ea" "-ka")
  85     (buffer-string)))
  86
  87 (defun filename-control-p (character)
  88   (let ((code (char-int character)))
  89     (or (< code 32)(= code 127))))
  90
  91 (defun filename-special-filter (string)
  92   (let ((len (length string))
  93         (b 0)(i 0)
  94         (dest ""))
  95     (while (< i len)
  96       (let ((chr (sref string i))
  97             (lst filename-replacement-alist)
  98             ret)
  99         (while (and lst (not ret))
 100           (if (if (functionp (car (car lst)))
 101                   (setq ret (funcall (car (car lst)) chr))
 102                 (setq ret (memq chr (car (car lst)))))
 103               t                         ; quit this loop.
 104             (setq lst (cdr lst))))
 105         (if ret
 106             (setq dest (concat dest (substring string b i)(cdr (car lst)))
 107                   i (+ i (char-length chr))
 108                   b i)
 109           (setq i (+ i (char-length chr))))))
 110     (concat dest (substring string b))))
 111
 112 (defun filename-eliminate-top-low-lines (string)
 113   (if (string-match "^_+" string)
 114       (substring string (match-end 0))
 115     string))
 116
 117 (defun filename-canonicalize-low-lines (string)
 118   (let ((dest ""))
 119     (while (string-match "__+" string)
 120       (setq dest (concat dest (substring string 0 (1+ (match-beginning 0)))))
 121       (setq string (substring string (match-end 0))))
 122     (concat dest string)))
 123
 124 (defun filename-maybe-truncate-by-size (string)
 125   (if (and (> (length string) filename-limit-length)
 126            (string-match "_" string filename-limit-length))
 127       (substring string 0 (match-beginning 0))
 128     string))
 129
 130 (defun filename-eliminate-bottom-low-lines (string)
 131   (if (string-match "_+$" string)
 132       (substring string 0 (match-beginning 0))
 133     string))
 134
 135
 136 ;;; @ interface
 137 ;;;
 138
 139 (defun replace-as-filename (string)
 140   "Return safety filename from STRING.
 141 It refers variable `filename-filters' and default filters refers
 142 `filename-limit-length', `filename-replacement-alist'."
 143   (and string
 144        (poly-funcall filename-filters string)))
 145
 146
 147 ;;; @ end
 148 ;;;
 149
 150 (provide 'filename)
 151
 152 ;;; filename.el ends here