diff options
Diffstat (limited to 'emacs.d/nxhtml/nxhtml/html-move.el')
| -rw-r--r-- | emacs.d/nxhtml/nxhtml/html-move.el | 251 |
1 files changed, 251 insertions, 0 deletions
diff --git a/emacs.d/nxhtml/nxhtml/html-move.el b/emacs.d/nxhtml/nxhtml/html-move.el new file mode 100644 index 0000000..4fadf71 --- /dev/null +++ b/emacs.d/nxhtml/nxhtml/html-move.el @@ -0,0 +1,251 @@ +;;; html-move.el --- Move a file in a local file web site. +;; +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Created: Thu Jan 12 08:11:30 2006 +(defconst html-move:version "0.31") ;; Version: +;; Last-Updated: Tue Feb 20 23:59:43 2007 (3600 +0100) +;; Keywords: +;; Compatibility: +;; +;; Features that might be required by this library: +;; +;; None +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;;DO NOT USE YET! +;; +;; Functions for moving a file in a local file web site. Moves the +;; file and fixes the local affected links after the move. +;; +;; To use this file you may in your .emacs put +;; +;; (require 'html-move) +;; +;; Call the function `html-move-buffer-file' to move a file. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(eval-when-compile (add-to-list 'load-path default-directory load-path)) +(eval-when-compile (require 'html-site nil t)) +(require 'url-parse) + +(defun html-move-make-new-url (old-url from-dir to-dir) + "Make new relative url. +If OLD-URL is an absolute path then return it. Otherwise OLD-URL +is assumed to be relative FROM-DIR. Return a new url relative +TO-DIR that gives the same absolute path." + (if (or (file-name-absolute-p old-url) + (char-equal ?# (string-to-char old-url)) + (let ((urlobj (url-generic-parse-url old-url))) + (url-host urlobj))) + (progn + nil) + (let* ( + (relative-path (file-relative-name from-dir to-dir)) + (new-abs-url (expand-file-name (concat relative-path old-url) to-dir)) + (new-url (file-relative-name new-abs-url to-dir))) + new-url))) + + +(defun html-move-in-dir-tree (file tree) + (let ((rel-path (file-relative-name file tree))) + (or (string= "." rel-path) + (not (string= ".." (substring rel-path 0 2)))))) + +(defun html-move-buffer-file (to) + "Move current buffer file to another directory and/or name. +Correct the affected relative links in the moved file and the +links to the file moved in the directory tree +`html-site-current-site-dir'." + ;;(interactive "GMove to: ") + (interactive + (let* ((use-dialog-box nil) + (name (read-file-name "Move to (directory or file name): " + )) + ) + (list (expand-file-name name)))) + (html-site-current-ensure-site-defined) + (let ((from (buffer-file-name)) + (site-directory (html-site-current-site-dir))) + (unless from + (error "No buffer file name, can't move file!")) + (let* ((from-dir (file-name-directory from)) + (from-ext (file-name-extension from)) + to-dir + to-ext + new-name + new-file + new-buffer + relative-path) + (unless (html-move-in-dir-tree from-dir site-directory) + (error "Buffer file is not in site directory tree")) + (if (file-directory-p to) + (progn + (setq to-dir to) + (setq new-name (file-name-nondirectory from)) + ) + (setq to-ext (file-name-extension to)) + (unless (string= to-ext from-ext) + (if (not to-ext) + (error "Can't find directory %s (or missing extension?)" to) + (error "Move must not change file extension"))) + (setq to-dir (file-name-directory to)) + (unless (file-directory-p to-dir) + (if (file-exists-p to-dir) + (error "Not a directory: %s" to-dir) + (error "Can't find directory %s" to-dir))) + (setq new-name (file-name-nondirectory to)) + ) + + (unless (html-move-in-dir-tree to-dir site-directory) + (error "Target is not in site directory tree")) + + + (setq relative-path (file-relative-name to-dir from-dir)) + (when (file-name-absolute-p relative-path) + (error "Can't make a relative path from %s to %s" from to)) + (setq new-file (expand-file-name new-name to)) + (let ((moved-buffer (current-buffer)) + (moved-contents (buffer-substring-no-properties + (point-min) + (point-max)))) + (when (file-exists-p new-file) + (error "File already exists: %s" new-file)) + ;; Open in new location + (find-file new-file) + (setq new-buffer (current-buffer)) + (erase-buffer) + (insert moved-contents) + (goto-char (point-min)) + (while (re-search-forward "\\(?:href\\|src\\)\\s-*=\\s-*\"\\([^\"]*\\)\"" nil t) + (let ((old-url (match-string 1)) + (new-url)) + (unless (or (> 11 (length old-url)) + (string= "javascript:" + (downcase (substring old-url 0 11)))) + (setq new-url (html-move-make-new-url old-url from-dir to-dir)) + (when new-url + (replace-match new-url t t nil 1))))) + (save-buffer) + (html-move-fix-site-backlinks from to-dir from-dir) + ;; Make backup at current location of "from" file + (with-current-buffer moved-buffer + (set-buffer-modified-p t) + (save-buffer)) + (kill-buffer moved-buffer) + ;; Delete moved + (delete-file from)) + (set-buffer new-buffer) + (goto-char (point-min)) + (lwarn '(html-move) :warning "Moved to %s" new-file) + ))) + +(defun html-move-fix-site-backlinks (to-moved-file to-dir from-dir) + "Fix all links back to TO-MOVED-FILE. +This is called by `html-move-buffer-file' to fix all links back +to the moved file. TO-MOVED-FILE is the old location of the +moved file. FROM-DIR is the old directory and TO-DIR the target +directory for the move." + (html-move-fix-all-backlinks to-moved-file (html-site-current-site-dir) to-dir from-dir) + (when (html-move-fix-page-list to-moved-file to-dir from-dir) + (message "Page list for site TOC changed. You need to update TOC.") + (lwarn '(html-move-fix-site-backlinks) :warning "Page list for site TOC changed. You need to update TOC.") + )) + +(defun html-move-fix-all-backlinks (to-moved-file for-dir to-dir from-dir) + ;;(message "for-dir=%s" for-dir);(sit-for 2) + (let ((html-files (directory-files for-dir t ".*\\.html?$")) + (sub-dirs (directory-files-and-attributes for-dir t))) + (dolist (html-file html-files) + (html-move-fix-backlinks to-moved-file html-file to-dir from-dir)) + (dolist (sub-entry sub-dirs) + (let* ((sub-dir (car sub-entry)) + (sub-name (file-name-nondirectory sub-dir))) + (when (and (eq t (car (cdr sub-entry))) + (not (string= "." sub-name)) + (not (string= ".." sub-name))) + (html-move-fix-all-backlinks to-moved-file sub-dir to-dir from-dir)))))) + +(defun html-move-fix-backlinks (to-moved-file for-file to-dir from-dir) + (when (file-exists-p for-file) + (let ((old-file-buffer (get-file-buffer for-file)) + (buffer (find-file-noselect for-file))) + (with-current-buffer buffer + (goto-char (point-min)) + (while + (re-search-forward + "\\(?:href\\|src\\)\\s-*=\\s-*\"\\([^#\"]*\\)\\(?:#[^\"]*\\|\\)\"" + nil t) + (let* ((old-url (match-string 1)) + (old-absolute-url (expand-file-name + old-url + (file-name-directory for-file))) + new-url) + (when (string= old-absolute-url to-moved-file) + (setq new-url (html-move-make-new-url old-url to-dir from-dir)) + ;;(message "new-backlink=%s" new-url);(sit-for 2) + (replace-match new-url t t nil 1) + ))) + (save-buffer) + (unless old-file-buffer + (kill-this-buffer)))))) + +(defun html-move-fix-page-list (to-moved-file to-dir from-dir) + (let ((for-file (html-site-current-page-list)) + some-change) + (when (file-exists-p for-file) + (let ((old-file-buffer (get-file-buffer for-file)) + (buffer (find-file-noselect for-file))) + (with-current-buffer buffer + (goto-char (point-min)) + (while + (re-search-forward + ;;"\\(?:href\\|src\\)\\s-*=\\s-*\"\\([^#\"]*\\)\\(?:#[^\"]*\\|\\)\"" + "\\s-+###\\s-+\\([^#]*?\\)\\(?:#[^#]*\\|\\)[:space:]*$" + nil t) + (let* ((old-url (match-string 1)) + (old-absolute-url (expand-file-name + old-url + (file-name-directory for-file))) + new-url) + (when (string= old-absolute-url to-moved-file) + (setq new-url (html-move-make-new-url old-url to-dir from-dir)) + ;;(message "new-backlink=%s" new-url);(sit-for 2) + (replace-match new-url t t nil 1) + (setq some-change t) + ))) + (save-buffer) + (unless old-file-buffer + (kill-this-buffer))))) + some-change)) + +(provide 'html-move) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; html-move.el ends here |