emacs/nxhtml/nxhtml/html-move.el

   1 ;;; html-move.el --- Move a file in a local file web site.
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: Thu Jan 12 08:11:30 2006
   5 (defconst html-move:version "0.31") ;; Version:
   6 ;; Last-Updated: Tue Feb 20 23:59:43 2007 (3600 +0100)
   7 ;; Keywords:
   8 ;; Compatibility:
   9 ;;
  10 ;; Features that might be required by this library:
  11 ;;
  12 ;;   None
  13 ;;
  14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15 ;;
  16 ;;; Commentary:
  17 ;;
  18 ;;DO NOT USE YET!
  19 ;;
  20 ;;  Functions for moving a file in a local file web site. Moves the
  21 ;;  file and fixes the local affected links after the move.
  22 ;;
  23 ;;  To use this file you may in your .emacs put
  24 ;;
  25 ;;      (require 'html-move)
  26 ;;
  27 ;;  Call the function `html-move-buffer-file' to move a file.
  28 ;;
  29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30 ;;
  31 ;;; Change log:
  32 ;;
  33 ;;
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35 ;;
  36 ;; This program is free software; you can redistribute it and/or modify
  37 ;; it under the terms of the GNU General Public License as published by
  38 ;; the Free Software Foundation; either version 2, or (at your option)
  39 ;; any later version.
  40 ;;
  41 ;; This program is distributed in the hope that it will be useful,
  42 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  43 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  44 ;; GNU General Public License for more details.
  45 ;;
  46 ;; You should have received a copy of the GNU General Public License
  47 ;; along with this program; see the file COPYING.  If not, write to the
  48 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  49 ;; Boston, MA 02111-1307, USA.
  50 ;;
  51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52 ;;
  53 ;;; Code:
  54
  55 (eval-when-compile (add-to-list 'load-path default-directory load-path))
  56 (eval-when-compile (require 'html-site nil t))
  57 (require 'url-parse)
  58
  59 (defun html-move-make-new-url (old-url from-dir to-dir)
  60   "Make new relative url.
  61 If OLD-URL is an absolute path then return it.  Otherwise OLD-URL
  62 is assumed to be relative FROM-DIR. Return a new url relative
  63 TO-DIR that gives the same absolute path."
  64   (if (or (file-name-absolute-p old-url)
  65           (char-equal ?# (string-to-char old-url))
  66           (let ((urlobj (url-generic-parse-url old-url)))
  67             (url-host urlobj)))
  68       (progn
  69         nil)
  70     (let* (
  71            (relative-path (file-relative-name from-dir to-dir))
  72            (new-abs-url (expand-file-name (concat relative-path old-url) to-dir))
  73            (new-url (file-relative-name new-abs-url to-dir)))
  74       new-url)))
  75
  76
  77 (defun html-move-in-dir-tree (file tree)
  78   (let ((rel-path (file-relative-name file tree)))
  79     (or (string= "." rel-path)
  80         (not (string= ".." (substring rel-path 0 2))))))
  81
  82 (defun html-move-buffer-file (to)
  83   "Move current buffer file to another directory and/or name.
  84 Correct the affected relative links in the moved file and the
  85 links to the file moved in the directory tree
  86 `html-site-current-site-dir'."
  87   ;;(interactive "GMove to: ")
  88   (interactive
  89     (let* ((use-dialog-box nil)
  90            (name (read-file-name "Move to (directory or file name): "
  91                                  ))
  92            )
  93       (list (expand-file-name name))))
  94   (html-site-current-ensure-site-defined)
  95   (let ((from (buffer-file-name))
  96         (site-directory (html-site-current-site-dir)))
  97     (unless from
  98       (error "No buffer file name, can't move file!"))
  99     (let* ((from-dir (file-name-directory from))
 100            (from-ext (file-name-extension from))
 101            to-dir
 102            to-ext
 103            new-name
 104            new-file
 105            new-buffer
 106            relative-path)
 107       (unless (html-move-in-dir-tree from-dir site-directory)
 108         (error "Buffer file is not in site directory tree"))
 109       (if (file-directory-p to)
 110           (progn
 111             (setq to-dir to)
 112             (setq new-name (file-name-nondirectory from))
 113             )
 114         (setq to-ext (file-name-extension to))
 115         (unless (string= to-ext from-ext)
 116           (if (not to-ext)
 117               (error "Can't find directory %s (or missing extension?)" to)
 118             (error "Move must not change file extension")))
 119         (setq to-dir (file-name-directory to))
 120         (unless (file-directory-p to-dir)
 121           (if (file-exists-p to-dir)
 122               (error "Not a directory: %s" to-dir)
 123             (error "Can't find directory %s" to-dir)))
 124         (setq new-name (file-name-nondirectory to))
 125         )
 126
 127       (unless (html-move-in-dir-tree to-dir site-directory)
 128         (error "Target is not in site directory tree"))
 129
 130
 131       (setq relative-path (file-relative-name to-dir from-dir))
 132       (when (file-name-absolute-p relative-path)
 133         (error "Can't make a relative path from %s to %s" from to))
 134       (setq new-file (expand-file-name new-name to))
 135       (let ((moved-buffer (current-buffer))
 136             (moved-contents (buffer-substring-no-properties
 137                              (point-min)
 138                              (point-max))))
 139         (when (file-exists-p new-file)
 140           (error "File already exists: %s" new-file))
 141         ;; Open in new location
 142         (find-file new-file)
 143         (setq new-buffer (current-buffer))
 144         (erase-buffer)
 145         (insert moved-contents)
 146         (goto-char (point-min))
 147         (while (re-search-forward "\\(?:href\\|src\\)\\s-*=\\s-*\"\\([^\"]*\\)\"" nil t)
 148           (let ((old-url (match-string 1))
 149                 (new-url))
 150             (unless (or (> 11 (length old-url))
 151                         (string= "javascript:"
 152                                  (downcase (substring old-url 0 11))))
 153               (setq new-url (html-move-make-new-url old-url from-dir to-dir))
 154               (when new-url
 155                 (replace-match new-url t t nil 1)))))
 156         (save-buffer)
 157         (html-move-fix-site-backlinks from to-dir from-dir)
 158         ;; Make backup at current location of "from" file
 159         (with-current-buffer moved-buffer
 160           (set-buffer-modified-p t)
 161           (save-buffer))
 162         (kill-buffer moved-buffer)
 163         ;; Delete moved
 164         (delete-file from))
 165       (set-buffer new-buffer)
 166       (goto-char (point-min))
 167       (lwarn '(html-move) :warning "Moved to %s" new-file)
 168       )))
 169
 170 (defun html-move-fix-site-backlinks (to-moved-file to-dir from-dir)
 171   "Fix all links back to TO-MOVED-FILE.
 172 This is called by `html-move-buffer-file' to fix all links back
 173 to the moved file.  TO-MOVED-FILE is the old location of the
 174 moved file. FROM-DIR is the old directory and TO-DIR the target
 175 directory for the move."
 176   (html-move-fix-all-backlinks to-moved-file (html-site-current-site-dir) to-dir from-dir)
 177   (when (html-move-fix-page-list to-moved-file to-dir from-dir)
 178     (message "Page list for site TOC changed. You need to update TOC.")
 179     (lwarn '(html-move-fix-site-backlinks) :warning "Page list for site TOC changed. You need to update TOC.")
 180     ))
 181
 182 (defun html-move-fix-all-backlinks (to-moved-file for-dir to-dir from-dir)
 183   ;;(message "for-dir=%s" for-dir);(sit-for 2)
 184   (let ((html-files (directory-files                for-dir t ".*\\.html?$"))
 185         (sub-dirs   (directory-files-and-attributes for-dir t)))
 186     (dolist (html-file html-files)
 187       (html-move-fix-backlinks to-moved-file html-file to-dir from-dir))
 188     (dolist (sub-entry sub-dirs)
 189       (let* ((sub-dir (car sub-entry))
 190              (sub-name (file-name-nondirectory sub-dir)))
 191         (when (and (eq t (car (cdr sub-entry)))
 192                    (not (string= "." sub-name))
 193                    (not (string= ".." sub-name)))
 194           (html-move-fix-all-backlinks to-moved-file sub-dir to-dir from-dir))))))
 195
 196 (defun html-move-fix-backlinks (to-moved-file for-file to-dir from-dir)
 197   (when (file-exists-p for-file)
 198     (let ((old-file-buffer (get-file-buffer for-file))
 199           (buffer (find-file-noselect for-file)))
 200       (with-current-buffer buffer
 201         (goto-char (point-min))
 202         (while
 203             (re-search-forward
 204              "\\(?:href\\|src\\)\\s-*=\\s-*\"\\([^#\"]*\\)\\(?:#[^\"]*\\|\\)\""
 205              nil t)
 206           (let* ((old-url (match-string 1))
 207                (old-absolute-url (expand-file-name
 208                                   old-url
 209                                   (file-name-directory for-file)))
 210                new-url)
 211             (when (string= old-absolute-url to-moved-file)
 212               (setq new-url (html-move-make-new-url old-url to-dir from-dir))
 213               ;;(message "new-backlink=%s" new-url);(sit-for 2)
 214               (replace-match new-url t t nil 1)
 215               )))
 216         (save-buffer)
 217         (unless old-file-buffer
 218           (kill-this-buffer))))))
 219
 220 (defun html-move-fix-page-list (to-moved-file to-dir from-dir)
 221   (let ((for-file (html-site-current-page-list))
 222         some-change)
 223     (when (file-exists-p for-file)
 224       (let ((old-file-buffer (get-file-buffer for-file))
 225             (buffer (find-file-noselect for-file)))
 226         (with-current-buffer buffer
 227           (goto-char (point-min))
 228           (while
 229               (re-search-forward
 230                ;;"\\(?:href\\|src\\)\\s-*=\\s-*\"\\([^#\"]*\\)\\(?:#[^\"]*\\|\\)\""
 231                "\\s-+###\\s-+\\([^#]*?\\)\\(?:#[^#]*\\|\\)[:space:]*$"
 232                nil t)
 233             (let* ((old-url (match-string 1))
 234                    (old-absolute-url (expand-file-name
 235                                       old-url
 236                                       (file-name-directory for-file)))
 237                    new-url)
 238               (when (string= old-absolute-url to-moved-file)
 239                 (setq new-url (html-move-make-new-url old-url to-dir from-dir))
 240                 ;;(message "new-backlink=%s" new-url);(sit-for 2)
 241                 (replace-match new-url t t nil 1)
 242                 (setq some-change t)
 243                 )))
 244           (save-buffer)
 245           (unless old-file-buffer
 246             (kill-this-buffer)))))
 247     some-change))
 248
 249 (provide 'html-move)
 250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 251 ;;; html-move.el ends here